home *** CD-ROM | disk | FTP | other *** search
/ Soil Vegetation Inventory Method / Soil Vegetation Inventory Method SVIM Source Code and Data - 1991.iso / doc / svim_pgm.doc < prev   
Encoding:
Text File  |  1991-08-01  |  1.5 MB  |  34,679 lines

Text Truncated. Only the first 1MB is shown below. Download the file for the complete contents.
  1. SVIM-PGM.DOC
  2. 000000*-----------------------------------------------------------------
  3. 000100         THE FOLLOWING SOURCE COBOL PROGRAMS WERE THE MOST
  4. 000200             BASIC PROGRAMS USED IN THE ROUTINE PROCESSING
  5. 000300             OF THE SOIL VEGETATION INVENTORY METHOD (SVIM).
  6. 000400             FILES/PROGRAMS PREFIXED BY ES (ECOLOGICAL SITE) IS
  7. 000500             SYNONYMOUS WITH THE SV (SVIM) SYSTEM CODE.
  8. 000600
  9. 000000*-----------------------------------------------------------------
  10. 000100 IDENTIFICATION DIVISION.
  11. 000200 PROGRAM-ID. ES005M.
  12. 000300*        CONVERTS THE "V1D" FORMATS TO THE NEW "V1A" FORMATS.
  13. 000400*
  14. 000500 AUTHOR. RON BAKER.
  15. 000500 DATE-WRITTEN.   01/22/80.
  16. 000600 DATE-COMPILED.
  17. 000700 ENVIRONMENT DIVISION.
  18. 000800 CONFIGURATION SECTION.
  19. 000900 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  20. 001000 OBJECT-COMPUTER.  LEVEL-66-ASCII.
  21. 001100 INPUT-OUTPUT SECTION.
  22. 001200 FILE-CONTROL.
  23. 001300 SELECT FIL-D1 ASSIGN TO D1
  24. 001400     ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  25. 001500 SELECT FIL-I1 ASSIGN TO I1
  26. 001600     ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  27. 001700 SELECT FIL-P1 ASSIGN TO P1
  28. 001800     ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  29. 001900 SELECT FIL-W1 ASSIGN TO W1
  30. 002000     ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  31. 002100 DATA DIVISION.
  32. 002200 FILE SECTION.
  33. 002300 FD  FIL-D1
  34. 002400     CODE-SET IS GBCD
  35. 002500     LABEL RECORDS ARE STANDARD
  36. 002600     DATA RECORD IS REC-D1.
  37. 002700 01  REC-D1  PIC X(156).
  38. 002800 FD  FIL-I1
  39. 002900     CODE-SET IS GBCD
  40. 003000     LABEL RECORDS ARE STANDARD
  41. 003100     DATA RECORD IS REC-I1.
  42. 003200 01  REC-I1.
  43. 003300     03  RECD-I1.
  44. 003400         05  REC-TYP-I1     PIC XX.
  45. 003500         05  FMT-NUM-I1     PIC 9.
  46. 003600         05  FMT-CD-I1      PIC X.
  47. 003700     03  SD-I1.
  48. 003800         05  ST-I1          PIC XX.
  49. 003900         05  DS-I1          PIC XX.
  50. 004000     03  RP-I1.
  51. 004100         05  RA-I1.
  52. 004200             07  RA-1-I1    PIC X.
  53. 004300             07  RA-2-I1    PIC X.
  54. 004400         05  PLU-I1         PIC XX.
  55. 004500     03  ALOT-I1            PIC XXXX.
  56. 004600     03  PAST-I1            PIC XX.
  57. 004700     03  SWAT-I1.
  58. 004800         05  SWA-I1.
  59. 004900             07  SWA-1-I1   PIC X.
  60. 005000             07  SWA-2-I1   PIC XXX.
  61. 005100         05  TRN-I1         PIC XX.
  62. 005200     03  DATA-V-I1   PIC X(216).
  63. 005300     03  DATA-V11-I1 REDEFINES DATA-V-I1.
  64. 005400         05  COMP-AREA-V11-I1    PIC X.
  65. 005500         05  DATE-V11-I1        PIC XXXXXX.
  66. 005600         05  ACT-V11-I1         PIC X.
  67. 005700         05  AER-V11-I1        PIC X(16).
  68. 005800         05  INT-V11-I1          PIC XXX.
  69. 005900         05  OCC-V11-I1  OCCURS 7 TIMES.
  70. 006000             07  HITS-V11-I1     PIC XXX.
  71. 006100             07  PLANTS-V11-I1   PIC X(21).
  72. 006200             07  RTNG-V11-I1     PIC XX.
  73. 006300         05  FILLER          PIC X(7).
  74. 006400     03  DATA-V12-I1 REDEFINES DATA-V-I1.
  75. 006500         05  FILLER       PIC X(8).
  76. 006600         05  LINE-V12-I1      PIC XXXX.
  77. 006700         05  OCCS-V12-I1   OCCURS 4 TIMES.
  78. 006800             07  CAN-V12-I1    PIC X(39).
  79. 006900         05  FILLER        PIC X(48).
  80. 007000     03  DATA-V13-I1 REDEFINES DATA-V-I1.
  81. 007100         05  FILLER      PIC X(8).
  82. 007200         05  LINE-V13-I1       PIC XXXX.
  83. 007300         05  OCC-V13-I1   OCCURS 9 TIMES.
  84. 007400             07  PLANT-V13-I1   PIC X(21).
  85. 007500         05  FILLER      PIC X(15).
  86. 007600     03  DATA-V21-I1 REDEFINES DATA-V-I1.
  87. 007700         05  DATE-V21-I1    PIC X(6).
  88. 007800         05  ACT-V21-I1     PIC X.
  89. 007900         05  TREE-PLOT-SZ-V21-I1  PIC X.
  90. 008000         05  GRASS-PLOT-SZ-V21-I1 PIC XXXXX.
  91. 008100         05  LINE-V21-I1    PIC XXXX.
  92. 008200         05  LINE-V21-I1-RD REDEFINES LINE-V21-I1 PIC 9999.
  93. 008300         05  OCC-V21-I1   OCCURS 4 TIMES.
  94. 008400             07  PLOT-NO-V21-I1.
  95. 008500                 09  PN-V21-P1-I1  PIC X.
  96. 008600                 09  PN-V21-P2-I1  PIC X.
  97. 008700             07  PLOT-NO-V21-I1-RD REDEFINES PLOT-NO-V21-I1
  98. 008800                 PIC 99.
  99. 008900             07  PLANT-V21-I1      PIC X(7).
  100. 009000             07  AVAIL-V21-I1      PIC X.
  101. 009100             07  PHNO-V21-I1       PIC X.
  102. 009200             07  UTIL-V21-I1       PIC X.
  103. 009300             07  HGT-CLS-GRP-V21-I1.
  104. 009400                 09  HGT-CLS-V21-I1  PIC XXXX OCCURS 4 TIMES.
  105. 009500             07  HCAF-V21-I1.
  106. 009600                 09  HGT-V21-I1       PIC XXXX.
  107. 009700                 09  HGT-V21-I1-RD REDEFINES
  108. 009800                                   HGT-V21-I1 PIC 999V9.
  109. 009900                 09  CRWN-V21-I1       PIC XXXX.
  110. 010000                 09  CRWN-V21-I1-RD REDEFINES
  111. 010100                                    CRWN-V21-I1 PIC 999V9.
  112. 010200                 09  AGE-V21-I1         PIC X.
  113. 010300                 09  FORM-V21-I1      PIC X.
  114. 010400             07  CHRZ-V21-I1       PIC XXX.
  115. 010500             07  NOT-CHRZ-V21-I1   PIC XXX.
  116. 010600         05  FILLER      PIC X(23).
  117. 010700 FD  FIL-P1
  118. 010800     CODE-SET IS GBCD
  119. 010900     LABEL RECORDS ARE STANDARD
  120. 011000     DATA RECORD IS REC-P1.
  121. 011100 01  REC-P1    PIC X(132).
  122. 011200 SD  FIL-W1
  123. 011300     DATA RECORD IS REC-W1.
  124. 011400 01  REC-W1.
  125. 011500     03  SD-W1   PIC XXXX.
  126. 011600     03  RA-W1   PIC XX.
  127. 011700     03  PAPSR-W1.
  128. 011800         05  PLU-W1    PIC XX.
  129. 011900         05  ALOT-W1   PIC XXXX.
  130. 012000         05  PAST-W1   PIC XX.
  131. 012100         05  SWAT-W1   PIC X(6).
  132. 012200         05  REC-TYP-W1 PIC XX.
  133. 012300         05  FMT-NUM-W1 PIC X.
  134. 012400         05  FMT-CD-W1 PIC X.
  135. 012500     03  GRP-2-W1.
  136. 012600         05  PLANT-W1     PIC X(7).
  137. 012700         05  HGT-W1       PIC X.
  138. 012800         05  HGT-W1-RD REDEFINES HGT-W1       PIC 9.
  139. 012900     03  PLOT-W1      PIC XX.
  140. 013000     03  PLOT-W1-RD REDEFINES PLOT-W1  PIC 99.
  141. 013100     03  OCC-W1      PIC 999.
  142. 013200     03  LINE-W1   PIC XXX.
  143. 013300     03  ACT-W1    PIC X.
  144. 013400     03  DATA-W1  PIC X(240).
  145. 013500     03  FILLER   PIC XXXXX.
  146. 013600 WORKING-STORAGE SECTION.
  147. 013700 77  REC-CNT  PIC 9(6) VALUE ZEROS.
  148. 013800 77  REC-TYP-W1-HLD   PIC XX  VALUE SPACE.
  149. 013900 77  WR-SW      PIC 9 VALUE ZERO.
  150. 014000 77  END-SW      PIC 9 VALUE ZERO.
  151. 014100 77  PLOT-TOT-HLD    PIC 99   VALUE ZERO.
  152. 014200 77  PLOT-NO-HLD    PIC 99   VALUE ZERO.
  153. 014300 77  LINE-V21-HLD    PIC 9999   VALUE ZERO.
  154. 014400 77  C99I    PIC 9(6)   VALUE ZERO.
  155. 014500 77  C11I    PIC 9(6)   VALUE ZERO.
  156. 014600 77  C12I    PIC 9(6)   VALUE ZERO.
  157. 014700 77  C13I    PIC 9(6)   VALUE ZERO.
  158. 014800 77  C21I    PIC 9(6)   VALUE ZERO.
  159. 014900 77  C11O    PIC 9(6)   VALUE ZERO.
  160. 015000 77  C12O    PIC 9(6)   VALUE ZERO.
  161. 015100 77  C13O    PIC 9(6)   VALUE ZERO.
  162. 015200 77  C14O    PIC 9(6)   VALUE ZERO.
  163. 015300 77  C21O    PIC 9(6)   VALUE ZERO.
  164. 015400 77  C31O    PIC 9(6)   VALUE ZERO.
  165. 015500 77  C99O    PIC 9(6)   VALUE ZERO.
  166. 015600 77  SS    PIC 9(6)   VALUE ZERO.
  167. 015700 77  LINE-CNT  PIC 9(3) VALUE ZEROS.
  168. 015800 77  GRP-1-V31-HLD    PIC X(20)  VALUE SPACE.
  169. 015900 77  GRP-2-V31-HLD    PIC X(8)  VALUE SPACE.
  170. 016000 77  WGT-HLD           PIC XXXX   VALUE SPACE.
  171. 016100 77  PLOT-HLD           PIC XX   VALUE SPACE.
  172. 016200 77  PAPSR-HLD        PIC X(18)  VALUE SPACE.
  173. 016300 77  SUB  PIC 9(3) VALUE ZEROS.
  174. 016400 77  CON-8   VALUE 008  PIC 999.
  175. 016500 77  SUB1  PIC 9(6) VALUE ZEROS.
  176. 016600 77  SUB9  PIC 9  VALUE ZEROS.
  177. 016700 77  PREV-CNTL   PIC X(20)   VALUE SPACE.
  178. 016800 01  PLOT-NUM-HOLD.
  179. 016900     03  PNH   PIC XX.
  180. 017000     03  PNH-RD REDEFINES PNH   PIC 99.
  181. 017100 01  PLOT-TABLE.
  182. 017200     03  PLOT-TAB   PIC 9   OCCURS 40 TIMES.
  183. 017300 01  REC-W1-HLD   PIC X(286)   VALUE SPACE.
  184. 017400 01  V-HLD.
  185. 017500     03  V-CNTL.
  186. 017600         05  BATCH-HLD      PIC XXXX.
  187. 017700         05  REC-TYP-HLD       PIC XX.
  188. 017800         05  FMT-NUM-HLD    PIC X.
  189. 017900         05  FMT-CD-HLD        PIC X.
  190. 018000         05  SD-HLD         PIC XXXX.
  191. 018100         05  PLU-HLD        PIC XX.
  192. 018200         05  ALOT-HLD       PIC XXXX.
  193. 018300         05  SWAT-HLD       PIC X(6).
  194. 018400     03  DATA-HLD    PIC X(128).
  195. 018500     03  RA-HLD   PIC XX.
  196. 018600     03  PAST-HLD PIC XX.
  197. 018700 01  V11.
  198. 018800     03  V11-CNTL.
  199. 018900         05  BATCH-V11      PIC XXXX.
  200. 019000         05  REC-TYP-V11       PIC XX.
  201. 019100         05  FMT-NUM-V11    PIC X.
  202. 019200         05  FMT-CD-V11        PIC X.
  203. 019300         05  SD-V11         PIC XXXX.
  204. 019400         05  PLU-V11        PIC XX.
  205. 019500         05  ALOT-V11       PIC XXXX.
  206. 019600         05  SWAT-V11       PIC X(6).
  207. 019700     03  DATA-V11.
  208. 019800         05  ACT-V11    PIC X.
  209. 019900         05  LINE-V11   PIC XXX.
  210. 020000         05  EDIT-FLG-V11   PIC X.
  211. 020100         05  SWAT-BRWD-V11   PIC X(6).
  212. 020200         05  FILLER          PIC X(28).
  213. 020300         05  DATE-V11 PIC X(6).
  214. 020400         05  INT-V11  PIC XXX.
  215. 020500         05  AER-V11  PIC X(16).
  216. 020600         05  CMPR-SD-V11  PIC XXXX.
  217. 020700         05  CMPR-FILLER   PIC X(12).
  218. 020800         05  FILLER    PIC X(48).
  219. 020900         05  RA-V11   PIC XX.
  220. 021000         05  PAST-V11 PIC XX.
  221. 021100 01  V12.
  222. 021200     03  V12-CNTL.
  223. 021300         05  BATCH-V12      PIC XXXX.
  224. 021400         05  REC-TYP-V12       PIC XX.
  225. 021500         05  FMT-NUM-V12    PIC X.
  226. 021600         05  FMT-CD-V12        PIC X.
  227. 021700         05  SD-V12         PIC XXXX.
  228. 021800         05  PLU-V12        PIC XX.
  229. 021900         05  ALOT-V12       PIC XXXX.
  230. 022000         05  SWAT-V12       PIC X(6).
  231. 022100     03  DATA-V12.
  232. 022200         05  ACT-V12   PIC X.
  233. 022300         05  LINE-V12  PIC 999.
  234. 022400         05  FILLER    PIC X(16).
  235. 022500         05  THP-V12.
  236. 022600             07  TYP-GC-V12  PIC X.
  237. 022700             07  HITS-GC-V12 PIC XXX.
  238. 022800             07  PLANT-V12   PIC X(21).
  239. 022900         05  FILLER    PIC X(7).
  240. 023000         05  FILLER    PIC X(76).
  241. 023100         05  RA-V12    PIC XX.
  242. 023200         05  PAST-V12  PIC XX.
  243. 023300 01  V13.
  244. 023400     03  V13-CNTL.
  245. 023500         05  BATCH-V13      PIC XXXX.
  246. 023600         05  REC-TYP-V13       PIC XX.
  247. 023700         05  FMT-NUM-V13    PIC X.
  248. 023800         05  FMT-CD-V13        PIC X.
  249. 023900         05  SD-V13         PIC XXXX.
  250. 024000         05  PLU-V13        PIC XX.
  251. 024100         05  ALOT-V13       PIC XXXX.
  252. 024200         05  SWAT-V13       PIC X(6).
  253. 024300     03  DATA-V13.
  254. 024400         05  ACT-V13   PIC X.
  255. 024500         05  LINE-V13     PIC XXX.
  256. 024600         05  FILLER       PIC X(16).
  257. 024700         05  PLANT-OCC-V13.
  258. 024800             07  CAN-V13 PIC X(39) OCCURS 2 TIMES.
  259. 024900         05  FILLER      PIC X(30).
  260. 025000         05  RA-V13    PIC XX.
  261. 025100         05  PAST-V13    PIC XX.
  262. 025200 01  V14.
  263. 025300     03  V14-CNTL.
  264. 025400         05    BATCH-V14      PIC XXXX.
  265. 025500         05    REC-TYP-V14       PIC XX.
  266. 025600         05    FMT-NUM-V14    PIC X.
  267. 025700         05    FMT-CD-V14        PIC X.
  268. 025800         05    SD-V14         PIC XXXX.
  269. 025900         05    PLU-V14        PIC XX.
  270. 026000         05    ALOT-V14       PIC XXXX.
  271. 026100         05    SWAT-V14       PIC X(6).
  272. 026200     03  DATA-V14.
  273. 026300         05  ACT-V14    PIC X.
  274. 026400         05  LINE-V14     PIC 999.
  275. 026500         05  FILLER     PIC X(16).
  276. 026600         05  SSF-V14  OCCURS 7 TIMES  PIC XX.
  277. 026700         05  FILLER       PIC X(94).
  278. 026800         05  RA-V14    PIC XX.
  279. 026900         05  PAST-V14   PIC XX.
  280. 027000 01  V21.
  281. 027100     03  V21-CNTL.
  282. 027200         05  BATCH-V21      PIC XXXX.
  283. 027300         05  REC-TYP-V21       PIC XX.
  284. 027400         05  FMT-NUM-V21    PIC X.
  285. 027500         05  FMT-CD-V21        PIC X.
  286. 027600         05  SD-V21         PIC XXXX.
  287. 027700         05  PLU-V21        PIC XX.
  288. 027800         05  ALOT-V21       PIC XXXX.
  289. 027900         05  SWAT-V21       PIC X(6).
  290. 028000     03  DATA-V21.
  291. 028100         05  ACT-V21    PIC X.
  292. 028200         05  LINE-V21    PIC 999.
  293. 028300         05  FILLER    PIC X(16).
  294. 028400         05  PLOT-SZ-V21   PIC X.
  295. 028500         05  PLOT-NUM-V21  PIC XX.
  296. 028600         05  PLANT-V21.
  297. 028700             07  P1P-V21  PIC X.
  298. 028800             07  P2P-V21  PIC X.
  299. 028900             07  P3P-V21  PIC X.
  300. 029000             07  P4P-V21  PIC X.
  301. 029100             07  P5P-V21  PIC X.
  302. 029200             07  P6P-V21  PIC X.
  303. 029300             07  P7P-V21  PIC X.
  304. 029400         05  AGE-V21      PIC X.
  305. 029500         05  FORM-V21      PIC X.
  306. 029600         05  PHNO-V21      PIC X.
  307. 029700         05  AVAIL-V21    PIC X.
  308. 029800         05  UTIL-V21      PIC X.
  309. 029900         05  HGT-V21       PIC X(5).
  310. 030000         05  HGT-V21-RD REDEFINES HGT-V21  PIC 999V99.
  311. 030100         05  CHRZ-V21      PIC XXX.
  312. 030200         05  FILLER        PIC XXXXX.
  313. 030300         05  CRWN-V21.
  314. 030400             07  CRWN-V21-3P    PIC XXX.
  315. 030500             07  CRWN-V21-1P1    PIC X.
  316. 030600             07  CRWN-V21-1P2    PIC X.
  317. 030700         05  CRWN-V21-RD REDEFINES CRWN-V21  PIC 999V99.
  318. 030800         05  NOT-CHRZ-V21  PIC XXX.
  319. 030900         05  FILLER        PIC X(72).
  320. 031000         05  RA-V21        PIC XX.
  321. 031100         05  PAST-V21      PIC XX.
  322. 031200 01  V31.
  323. 031300     03  V31-CNTL.
  324. 031400         05  BATCH-V31      PIC XXXX.
  325. 031500         05  GRP-1-V31.
  326. 031600             07  REC-TYP-V31       PIC XX.
  327. 031700             07  FMT-NUM-V31    PIC X.
  328. 031800             07  FMT-CD-V31        PIC X.
  329. 031900             07  SD-V31         PIC XXXX.
  330. 032000             07  PLU-V31        PIC XX.
  331. 032100             07  ALOT-V31       PIC XXXX.
  332. 032200             07  SWAT-V31       PIC X(6).
  333. 032300     03  DATA-V31.
  334. 032400         05  ACT-V31    PIC X.
  335. 032500         05  LINE-V31   PIC XXX.
  336. 032600         05  FILLER     PIC X(16).
  337. 032700         05  PLOT-TOT-V31    PIC XX.
  338. 032800         05  PLOT-SZ-2P-V31    PIC X(2).
  339. 032900         05  PLOT-SZ-5P-V31.
  340. 033000             07  PSZ-3P   PIC XXX.
  341. 033100             07  PSZ-2P   PIC XX.
  342. 033200         05  GRP-2-V31.
  343. 033300             07  PLANT-V31.
  344. 033400                 09  P1P-V31  PIC X.
  345. 033500                 09  P2P-V31  PIC X.
  346. 033600                 09  P3P-V31  PIC X.
  347. 033700                 09  P4P-V31  PIC X.
  348. 033800                 09  P5P-V31  PIC X.
  349. 033900                 09  P6P-V31  PIC X.
  350. 034000                 09  P7P-V31  PIC X.
  351. 034100             07  HGT-V31        PIC X.
  352. 034200         05  PLOT-DATA  OCCURS 10 TIMES.
  353. 034300             07  PLOT-V31   PIC XX.
  354. 034400             07  AVAIL-V31  PIC X.
  355. 034500             07  PHNO-V31   PIC X.
  356. 034600             07  UTIL-V31   PIC X.
  357. 034700             07  WGT-V31    PIC XXXX.
  358. 034800        05  FILLER      PIC X.
  359. 034900        05  RA-V31      PIC XX.
  360. 035000        05  PAST-V31    PIC XX.
  361. 035100 01 GROUND-CVR-TAB.
  362. 035200    03  TGC-TAB  PIC X(7)   VALUE "BPNGCSR".
  363. 035300    03  TGC REDEFINES TGC-TAB   PIC X  OCCURS 7 TIMES.
  364. 035400 PROCEDURE DIVISION.
  365. 035500 SORT-STATEMENT SECTION.
  366. 035600 SORT-STATEMENT-PARA.
  367. 035700     SORT FIL-W1 ON ASCENDING KEY SD-W1,
  368. 035800         PLU-W1, ALOT-W1, PAST-W1, SWAT-W1,
  369. 035900           PLANT-W1, HGT-W1, PLOT-W1,
  370. 036000                    REC-TYP-W1, FMT-CD-W1, FMT-NUM-W1,
  371. 036100                  LINE-W1, ACT-W1
  372. 036200     INPUT PROCEDURE IS INPUT-PROC,
  373. 036300     OUTPUT PROCEDURE IS OUTPUT-PROC.
  374. 036400 STOP-RUN.
  375. 036500     DISPLAY "V11I " C11I.
  376. 036600     DISPLAY "V12I " C12I.
  377. 036700     DISPLAY "V13I " C13I.
  378. 036800     DISPLAY "V21I " C21I.
  379. 036900     DISPLAY "V11O " C11O.
  380. 037000     DISPLAY "V12O " C12O.
  381. 037100     DISPLAY "V13O " C13O.
  382. 037200     DISPLAY "V14O " C14O.
  383. 037300     DISPLAY "V21O " C21O.
  384. 037400     DISPLAY "V31O " C31O.
  385. 037500     DISPLAY "V99O " C99O.
  386. 037600     CLOSE FIL-D1, FIL-P1.  STOP RUN.
  387. 037700 INPUT-PROC SECTION.
  388. 037800 010-HOUSEKEEPING.
  389. 037900     OPEN INPUT FIL-I1.
  390. 038000         INITIALIZE PLOT-TABLE.
  391. 038100 010A-READ.
  392. 038200     MOVE SPACE TO REC-W1.
  393. 038300     READ FIL-I1 AT END GO TO 099-CLOSE.
  394. 038400     IF SWA-1-I1 = "0" MOVE "O" TO SWA-1-I1.
  395. 038500     IF SWA-I1 = SPACE
  396. 038600         MOVE "Z999" TO SWA-I1.
  397. 038700     IF ST-I1 = "OT" MOVE "UT" TO ST-I1.
  398. 038800*    MOVE "8" TO RA-2-I1.
  399. 038900*    IF SD-I1 = "UT08" OR "UT07" OR "UT02"
  400. 039000     IF ST-I1 = "UT"
  401. 039100         MOVE "UT08" TO SD-I1
  402. 039200         MOVE "5807" TO RP-I1.
  403. 039300     ADD 1 TO C99I.
  404. 039400*    DISPLAY REC-I1.
  405. 039500     MOVE REC-I1 TO DATA-W1.
  406. 039600*    IF REC-CNT > 200 GO TO 099-CLOSE.
  407. 039700     MOVE REC-TYP-I1 TO REC-TYP-W1.
  408. 039800     MOVE FMT-NUM-I1 TO FMT-NUM-W1.
  409. 039900     MOVE FMT-CD-I1 TO FMT-CD-W1.
  410. 040000     MOVE SD-I1 TO SD-W1.
  411. 040100     MOVE RA-I1 TO RA-W1.
  412. 040200     MOVE PLU-I1 TO PLU-W1.
  413. 040300     MOVE ALOT-I1 TO ALOT-W1.
  414. 040400     MOVE PAST-I1 TO PAST-W1.
  415. 040500     MOVE SWAT-I1 TO SWAT-W1.
  416. 040600     IF RECD-I1 = "V11D" OR "V12D" OR "V13D" OR "V21D"
  417. 040700         NEXT SENTENCE ELSE
  418. 040800             DISPLAY "BAD " REC-I1
  419. 040900             DISPLAY "COUNT= " C99I
  420. 041000             GO TO 010A-READ.
  421. 041100     IF RECD-I1 = "V11D"
  422. 041200         ADD 1 TO C11I
  423. 041300         MOVE SPACES TO LINE-W1.
  424. 041400     IF RECD-I1 = "V12D"
  425. 041500         ADD 1 TO C12I
  426. 041600         MOVE LINE-V12-I1 TO LINE-W1.
  427. 041700     IF RECD-I1 = "V21D"
  428. 041800         ADD 1 TO C21I
  429. 041900         MOVE LINE-V21-I1 TO LINE-W1
  430. 042000         MOVE REC-W1 TO REC-W1-HLD.
  431. 042100     IF RECD-I1 = "V11D" OR "V12D" OR "V13D" OR "V21D"
  432. 042200         NEXT SENTENCE ELSE
  433. 042300             DISPLAY "BAD " REC-I1
  434. 042400             DISPLAY "COUNT= " C99I
  435. 042500             GO TO 010A-READ.
  436. 042600     IF RECD-I1 = "V13D"
  437. 042700         ADD 1 TO C13I
  438. 042800         MOVE LINE-V13-I1 TO LINE-W1.
  439. 042900     RELEASE REC-W1.
  440. 043000     IF RECD-I1 NOT = "V21D"
  441. 043100        GO TO 010A-READ.
  442. 043200     MOVE ZERO TO SUB, SUB9.
  443. 043300 090-LOOP.
  444. 043400     ADD 1 TO SUB.
  445. 043500     IF SUB = 5 GO TO 010A-READ.
  446. 043600     IF ((PN-V21-P2-I1 (SUB) = SPACE) AND
  447. 043700         (PN-V21-P1-I1 (SUB)  NOT = SPACE))
  448. 043800         MOVE PN-V21-P1-I1 (SUB) TO PN-V21-P2-I1 (SUB)
  449. 043900         MOVE ZERO TO PN-V21-P1-I1 (SUB).
  450. 044000     MOVE PLOT-NO-V21-I1 (SUB) TO PNH.
  451. 044100     IF (PNH = "00" OR "99") OR
  452. 044200         ((PNH-RD > 40) AND (PNH-RD < 99))
  453. 044300             DISPLAY "INV " REC-I1
  454. 044400             DISPLAY "COUNT= " C99I
  455. 044500             GO TO 090-LOOP.
  456. 044600         IF (PNH NOT NUMERIC)
  457. 044700         AND (PLANT-V21-I1 (SUB) NOT = SPACE)
  458. 044800             DISPLAY "BAD " REC-I1
  459. 044900             DISPLAY "COUNT= " C99I
  460. 045000             GO TO 090-LOOP.
  461. 045100         IF (PNH NOT NUMERIC)
  462. 045200             GO TO 090-LOOP.
  463. 045300     IF HGT-CLS-GRP-V21-I1 (SUB) = SPACE
  464. 045400         GO TO 090-LOOP.
  465. 045500 095-LOOP.
  466. 045600     ADD 1 TO SUB9.
  467. 045700     IF SUB9 = 5
  468. 045800         MOVE ZERO TO SUB9
  469. 045900         GO TO 090-LOOP.
  470. 046000     IF HGT-CLS-V21-I1 (SUB, SUB9) = SPACE
  471. 046100         GO TO 095-LOOP.
  472. 046200     MOVE REC-W1-HLD TO REC-W1.
  473. 046300     MOVE PLANT-V21-I1 (SUB) TO PLANT-W1.
  474. 046400     MOVE SUB9 TO HGT-W1.
  475. 046500     MOVE PLOT-NO-V21-I1 (SUB) TO PLOT-W1.
  476. 046600     MOVE SPACE TO LINE-W1.
  477. 046700     MOVE "V3" TO REC-TYP-W1.
  478. 046800     IF PLOT-W1-RD < 11 MOVE "1" TO FMT-NUM-W1
  479. 046900         ELSE IF PLOT-W1-RD < 21 MOVE "2" TO FMT-NUM-W1
  480. 047000         ELSE IF PLOT-W1-RD < 31 MOVE "3" TO FMT-NUM-W1
  481. 047100         ELSE IF PLOT-W1-RD < 41 MOVE "4" TO FMT-NUM-W1.
  482. 047200     MOVE SUB TO OCC-W1.
  483. 047300     RELEASE REC-W1.
  484. 047400     GO TO 095-LOOP.
  485. 047500 099-CLOSE.
  486. 047600     CLOSE FIL-I1.
  487. 047700 099-EXIT.
  488. 047800     EXIT.
  489. 047900 OUTPUT-PROC SECTION.
  490. 048000 100-OPEN.
  491. 048100     DISPLAY "OUTPUT PROC".
  492. 048200     OPEN OUTPUT FIL-D1, FIL-P1.
  493. 048300 100-RET.
  494. 048400     RETURN FIL-W1 AT END GO TO 999-END.
  495. 048500 105-CK-REC.
  496. 048600     IF END-SW = 1
  497. 048700         GO TO 999-END.
  498. 048800*    DISPLAY "SR= " REC-W1.
  499. 048900*    DISPLAY "GOD " DATA-W1.
  500. 049000     ADD 1 TO REC-CNT.
  501. 049100*    IF REC-CNT > 200 GO TO 999-END.
  502. 049200     IF (REC-TYP-W1 NOT = REC-TYP-W1-HLD) AND
  503. 049300         (REC-TYP-W1-HLD = "V2")
  504. 049400         MOVE 008 TO CON-8
  505. 049500         PERFORM 115-PLOT-TAB THRU 115-EXIT.
  506. 049600     MOVE DATA-W1 TO REC-I1.
  507. 049700     MOVE REC-TYP-W1 TO REC-TYP-W1-HLD.
  508. 049800     IF PLANT-W1 NOT = SPACE GO TO 600-V31.
  509. 049900     IF END-SW = 1 GO TO 999-END.
  510. 050000     IF RECD-I1 = "V11D" GO TO 200-V11.
  511. 050100     IF RECD-I1 = "V12D" GO TO 300-V12.
  512. 050200     IF RECD-I1 = "V13D" GO TO 400-V13.
  513. 050300     IF RECD-I1 = "V21D" GO TO 500-V21.
  514. 050400     GO TO 100-RET.
  515. 050500 110-LOAD.
  516. 050600     MOVE ZEROES TO BATCH-HLD.
  517. 050700     MOVE "A" TO FMT-CD-HLD.
  518. 050800     MOVE SD-I1 TO SD-HLD.
  519. 050900     MOVE PLU-I1 TO PLU-HLD.
  520. 051000     MOVE RA-I1 TO RA-HLD.
  521. 051100     MOVE ALOT-I1 TO ALOT-HLD.
  522. 051200     MOVE PAST-I1 TO PAST-HLD.
  523. 051300     MOVE SWAT-I1 TO SWAT-HLD.
  524. 051400 110-EXIT.
  525. 051500     EXIT.
  526. 051600 115-PLOT-TAB.
  527. 051700     MOVE ZERO TO SUB, PLOT-TOT-HLD.
  528. 051800 115-LOOP.
  529. 051900     ADD 1 TO SUB.
  530. 052000     IF SUB = 41
  531. 052100         INITIALIZE PLOT-TABLE
  532. 052200         GO TO 115-EXIT.
  533. 052300     ADD PLOT-TAB (SUB) TO PLOT-TOT-HLD.
  534. 052400     GO TO 115-LOOP.
  535. 052500 115-EXIT.
  536. 052600     EXIT.
  537. 052700 200-V11.
  538. 052800     MOVE SPACE TO V-HLD.
  539. 052900     PERFORM 110-LOAD.
  540. 053000     MOVE SPACE TO V11, V12, V14.
  541. 053100     MOVE V-CNTL TO V11-CNTL V12-CNTL V14-CNTL.
  542. 053200     MOVE ACT-V11-I1 TO ACT-V11 ACT-V12 ACT-V14.
  543. 053300     MOVE "V1" TO REC-TYP-V11.
  544. 053400     MOVE "1" TO FMT-NUM-V11.
  545. 053500     MOVE "000" TO LINE-V11.
  546. 053600     MOVE RA-HLD TO RA-V11.
  547. 053700     MOVE PAST-I1 TO PAST-V11.
  548. 053800     MOVE AER-V11-I1 TO AER-V11.
  549. 053900     MOVE INT-V11-I1 TO INT-V11.
  550. 054000     IF COMP-AREA-V11-I1 = "C"
  551. 054100         MOVE SD-I1 TO CMPR-SD-V11.
  552. 054200     MOVE ACT-V11-I1 TO ACT-V11.
  553. 054300     MOVE DATE-V11-I1 TO DATE-V11.
  554. 054400*    WRITE REC-P1 FROM V11.
  555. 054500     WRITE REC-D1 FROM V11.
  556. 054600         ADD 1 TO C11O.
  557. 054700         ADD 1 TO C99O.
  558. 054800     MOVE ZERO TO SUB.
  559. 054900 210-LOOP.
  560. 055000     ADD 1 TO SUB.
  561. 055100     IF SUB = 8 GO TO 250-V14.
  562. 055200     IF HITS-V11-I1 (SUB)  > ZERO
  563. 055300         MOVE TGC (SUB) TO TYP-GC-V12.
  564. 055400     MOVE SUB TO LINE-V12.
  565. 055500     MOVE HITS-V11-I1 (SUB) TO HITS-GC-V12.
  566. 055600     MOVE PLANTS-V11-I1 (SUB) TO PLANT-V12.
  567. 055700     IF RTNG-V11-I1 (SUB) = SPACE
  568. 055800         MOVE "99" TO SSF-V14 (SUB)
  569. 055900         ELSE MOVE RTNG-V11-I1 (SUB) TO SSF-V14 (SUB).
  570. 056000     IF (PLANT-V12 = SPACE) AND
  571. 056100         (TYP-GC-V12 = SPACE)
  572. 056200         GO TO 210-LOOP.
  573. 056300     MOVE "V1" TO REC-TYP-V12.
  574. 056400     MOVE "2" TO FMT-NUM-V12.
  575. 056500     MOVE RA-I1 TO RA-V12.
  576. 056600     MOVE PAST-I1 TO PAST-V12.
  577. 056700*    WRITE REC-P1 FROM V12.
  578. 056800     WRITE REC-D1 FROM V12.
  579. 056900     ADD 1 TO C12O.
  580. 057000     ADD 1 TO C99O.
  581. 057100     MOVE SPACE TO THP-V12.
  582. 057200     GO TO 210-LOOP.
  583. 057300 250-V14.
  584. 057400     MOVE 001 TO LINE-V14.
  585. 057500     MOVE "V1" TO REC-TYP-V14.
  586. 057600     MOVE "4" TO FMT-NUM-V14.
  587. 057700     MOVE RA-I1 TO RA-V14.
  588. 057800     MOVE PAST-I1 TO PAST-V14.
  589. 057900*    WRITE REC-P1 FROM V14.
  590. 058000     WRITE REC-D1 FROM V14.
  591. 058100     ADD 1 TO C14O.
  592. 058200     ADD 1 TO C99O.
  593. 058300     GO TO 100-RET.
  594. 058400 300-V12.
  595. 058500     PERFORM 110-LOAD.
  596. 058600     MOVE SPACE TO V13.
  597. 058700     MOVE V-CNTL TO V13-CNTL.
  598. 058800     MOVE ACT-V11-I1 TO ACT-V13.
  599. 058900     MOVE "V1" TO REC-TYP-V13.
  600. 059000     MOVE "3" TO FMT-NUM-V13.
  601. 059100     MOVE RA-I1 TO RA-V13.
  602. 059200     MOVE PAST-I1 TO PAST-V13.
  603. 059300     MOVE ZERO TO SUB SUB1.
  604. 059400 310-LOOP.
  605. 059500     ADD 1 TO SUB.
  606. 059600     IF (SUB = 5) AND (SUB1 = 1)
  607. 059700*        WRITE REC-P1 FROM V13
  608. 059800         WRITE REC-D1 FROM V13.
  609. 059900     IF SUB = 5 GO TO 100-RET.
  610. 060000     IF CAN-V12-I1 (SUB) NOT = SPACE
  611. 060100         ADD 1 TO SUB1
  612. 060200        MOVE CAN-V12-I1 (SUB) TO CAN-V13 (SUB1).
  613. 060300     IF SUB1 = 2
  614. 060400         ADD 1 TO C13O
  615. 060500         ADD 1 TO C99O
  616. 060600*        WRITE REC-P1 FROM V13
  617. 060700         WRITE REC-D1 FROM V13
  618. 060800         MOVE SPACE TO PLANT-OCC-V13
  619. 060900         MOVE ZERO TO SUB1.
  620. 061000     GO TO 310-LOOP.
  621. 061100 400-V13.
  622. 061200     PERFORM 110-LOAD.
  623. 061300     MOVE SPACE TO V12.
  624. 061400     MOVE V-CNTL TO V12-CNTL
  625. 061500     MOVE ACT-V11-I1 TO ACT-V12.
  626. 061600     MOVE "V1" TO REC-TYP-V12.
  627. 061700     MOVE "2" TO FMT-NUM-V12.
  628. 061800     MOVE RA-I1 TO RA-V12.
  629. 061900     MOVE PAST-I1 TO PAST-V12.
  630. 062000     MOVE ZERO TO SUB.
  631. 062100 410-LOOP.
  632. 062200     ADD 1 TO SUB.
  633. 062300     IF SUB = 10
  634. 062400         GO TO 100-RET.
  635. 062500     IF PLANT-V13-I1 (SUB) NOT = SPACE
  636. 062600         MOVE PLANT-V13-I1 (SUB) TO PLANT-V12
  637. 062700         ADD 1 TO C12O
  638. 062800         ADD 1 TO C99O
  639. 062900*        WRITE REC-P1 FROM V12
  640. 063000         WRITE REC-D1 FROM V12.
  641. 063100     GO TO 410-LOOP.
  642. 063200 500-V21.
  643. 063300     PERFORM 110-LOAD.
  644. 063400     MOVE SPACE TO V21.
  645. 063500     MOVE V-CNTL TO V21-CNTL.
  646. 063600     MOVE "V2" TO REC-TYP-V21.
  647. 063700     MOVE "1" TO FMT-NUM-V21.
  648. 063800     MOVE ACT-V21-I1 TO ACT-V21.
  649. 063900     MOVE RA-I1 TO RA-V21.
  650. 064000     MOVE PAST-I1 TO PAST-V21.
  651. 064100     MOVE TREE-PLOT-SZ-V21-I1 TO PLOT-SZ-V21.
  652. 064200     IF  LINE-V21-I1 = SPACE OR ZERO
  653. 064300         MOVE ZERO TO LINE-V21-HLD
  654. 064400         ELSE MOVE LINE-V21-I1-RD TO LINE-V21-HLD.
  655. 064500     MOVE ZERO TO SUB.
  656. 064600 510-LOOP.
  657. 064700     ADD 1 TO SUB.
  658. 064800     IF SUB = 5
  659. 064900         GO TO 100-RET.
  660. 065000     IF  (PLOT-NO-V21-I1-RD (SUB) > ZERO)
  661. 065100       AND (PLOT-NO-V21-I1-RD (SUB) < 41)
  662. 065200         MOVE PLOT-NO-V21-I1-RD (SUB) TO PLOT-NO-HLD
  663. 065300         MOVE 1 TO PLOT-TAB (PLOT-NO-HLD).
  664. 065400     IF (HCAF-V21-I1 (SUB)  = SPACE) AND
  665. 065500         (PLANT-V21-I1 (SUB)  NOT = "BARREN ")
  666. 065600         GO TO 510-LOOP.
  667. 065700     IF (PLANT-V21-I1 (SUB) = "BARREN ") AND
  668. 065800         (CHRZ-V21-I1 (SUB) > ZERO OR SPACE)
  669. 065900         GO TO 510-LOOP.
  670. 066000     MOVE PLOT-NO-V21-I1 (SUB) TO PLOT-NUM-V21.
  671. 066100     MOVE PLANT-V21-I1 (SUB) TO PLANT-V21.
  672. 066200     IF P1P-V21 = QUOTE MOVE "+" TO P1P-V21.
  673. 066300     IF P2P-V21 = QUOTE MOVE "+" TO P2P-V21.
  674. 066400     IF P3P-V21 = QUOTE MOVE "+" TO P3P-V21.
  675. 066500     IF P4P-V21 = QUOTE MOVE "+" TO P4P-V21.
  676. 066600     IF P5P-V21 = QUOTE MOVE "+" TO P5P-V21.
  677. 066700     IF P6P-V21 = QUOTE MOVE "+" TO P6P-V21.
  678. 066800     IF P7P-V21 = QUOTE MOVE "+" TO P7P-V21.
  679. 066900     MOVE AVAIL-V21-I1 (SUB) TO AVAIL-V21.
  680. 067000     IF AVAIL-V21 = "D" OR "E"  MOVE "P" TO AVAIL-V21.
  681. 067100     IF AVAIL-V21 = "J" MOVE "U" TO AVAIL-V21.
  682. 067200     IF AVAIL-V21 = "R" MOVE "A" TO AVAIL-V21.
  683. 067300     IF AVAIL-V21 = "D" OR "E"  MOVE "P" TO AVAIL-V21.
  684. 067400     MOVE PHNO-V21-I1 (SUB) TO PHNO-V21.
  685. 067500     IF PHNO-V21 = "G" MOVE "6" TO PHNO-V21.
  686. 067600     MOVE UTIL-V21-I1 (SUB) TO UTIL-V21.
  687. 067700     IF UTIL-V21 = "O" MOVE "0" TO UTIL-V21.
  688. 067800     MOVE AGE-V21-I1 (SUB) TO AGE-V21.
  689. 067900     IF AGE-V21 = "N" MOVE "M" TO AGE-V21.
  690. 068000     MOVE FORM-V21-I1 (SUB) TO FORM-V21.
  691. 068100     MOVE CHRZ-V21-I1 (SUB) TO CHRZ-V21.
  692. 068200     MOVE NOT-CHRZ-V21-I1 (SUB) TO NOT-CHRZ-V21.
  693. 068300     IF HGT-V21-I1 (SUB) NUMERIC
  694. 068400         MOVE HGT-V21-I1-RD (SUB) TO HGT-V21-RD
  695. 068500            ELSE MOVE HGT-V21-I1 (SUB) TO HGT-V21.
  696. 068600     IF CRWN-V21-I1 (SUB) NUMERIC
  697. 068700         MOVE CRWN-V21-I1-RD (SUB) TO CRWN-V21-RD
  698. 068800            ELSE MOVE CRWN-V21-I1 (SUB) TO CRWN-V21.
  699. 068900     IF (CRWN-V21-1P1 NOT = SPACE) AND
  700. 069000         (CRWN-V21-3P = SPACE)
  701. 069100         MOVE ZERO TO CRWN-V21-3P.
  702. 069200     IF (CRWN-V21-1P1 NOT = SPACE) AND
  703. 069300         (CRWN-V21-1P2 = SPACE)
  704. 069400         MOVE ZERO TO CRWN-V21-1P2.
  705. 069500*    IF PREV-CNTL NOT = V21-CNTL
  706. 069600*        MOVE ZERO TO LINE-CNTR.
  707. 069700*    ADD 1 TO LINE-CNTR.
  708. 069800*    MOVE LINE-CNTR TO LINE-V21.
  709. 069900*    MOVE V21-CNTL TO PREV-CNTL.
  710. 070000*    WRITE REC-P1 FROM V21.
  711. 070100     SUBTRACT 1 FROM SUB.
  712. 070200     IF LINE-V21-HLD > ZERO
  713. 070300         ADD SUB LINE-V21-HLD GIVING LINE-V21.
  714. 070400     ADD 1 TO SUB.
  715. 070500     WRITE REC-D1 FROM V21.
  716. 070600     ADD 1 TO C21O.
  717. 070700     ADD 1 TO C99O.
  718. 070800     GO TO 510-LOOP.
  719. 070900 600-V31.
  720. 071000     IF (SD-W1 = SD-HLD) AND (PAPSR-W1 = PAPSR-HLD)
  721. 071100         AND (GRP-2-W1 = GRP-2-V31-HLD)
  722. 071200         GO TO 620-PLOT.
  723. 071300     IF WR-SW = 1
  724. 071400         ADD 1 TO LINE-CNT
  725. 071500*        MOVE LINE-CNT TO LINE-V31
  726. 071600*        WRITE REC-P1 FROM V31
  727. 071700         WRITE REC-D1 FROM V31
  728. 071800         ADD 1 TO C31O
  729. 071900         ADD 1 TO C99O
  730. 072000         MOVE ZERO TO WR-SW.
  731. 072100     IF (SD-W1 = SD-HLD) AND (PAPSR-W1 = PAPSR-HLD)
  732. 072200         MOVE ZERO TO LINE-CNT.
  733. 072300     MOVE ZERO TO SUB.
  734. 072400     MOVE SPACE TO V31 PLOT-HLD.
  735. 072500     PERFORM 110-LOAD.
  736. 072600     MOVE V-CNTL TO V31-CNTL
  737. 072700     MOVE RA-HLD TO RA-V31.
  738. 072800     MOVE PAPSR-W1 TO PAPSR-HLD.
  739. 072900     MOVE PAST-HLD TO PAST-V31.
  740. 073000     MOVE "V3" TO REC-TYP-V31.
  741. 073100     MOVE RA-I1 TO RA-V31.
  742. 073200     MOVE PAST-I1 TO PAST-V31.
  743. 073300     MOVE FMT-NUM-W1 TO FMT-NUM-V31.
  744. 073400     IF ST-I1 = "UT" AND ((GRASS-PLOT-SZ-V21-I1 NOT NUMERIC) OR
  745. 073500         (GRASS-PLOT-SZ-V21-I1 = "00009"))
  746. 073600         MOVE "00960" TO GRASS-PLOT-SZ-V21-I1.
  747. 073700     MOVE GRASS-PLOT-SZ-V21-I1 TO PLOT-SZ-5P-V31.
  748. 073800     IF PLOT-SZ-5P-V31 NOT = SPACE
  749. 073900         MOVE ZERO TO PLOT-SZ-2P-V31.
  750. 074000     IF (PSZ-3P = SPACE) AND (PLOT-SZ-2P-V31 = ZERO)
  751. 074100         MOVE ZERO TO PSZ-3P.
  752. 074200     MOVE "B" TO FMT-CD-V31.
  753. 074300     MOVE SPACE TO LINE-V31.
  754. 074400     MOVE ACT-V21-I1 TO ACT-V31.
  755. 074500     MOVE HGT-W1 TO HGT-V31.
  756. 074600     MOVE PLANT-W1 TO PLANT-V31.
  757. 074700     IF P1P-V31 = QUOTE MOVE "+" TO P1P-V31.
  758. 074800     IF P2P-V31 = QUOTE MOVE "+" TO P2P-V31.
  759. 074900     IF P3P-V31 = QUOTE MOVE "+" TO P3P-V31.
  760. 075000     IF P4P-V31 = QUOTE MOVE "+" TO P4P-V31.
  761. 075100     IF P5P-V31 = QUOTE MOVE "+" TO P5P-V31.
  762. 075200     IF P6P-V31 = QUOTE MOVE "+" TO P6P-V31.
  763. 075300     IF P7P-V31 = QUOTE MOVE "+" TO P7P-V31.
  764. 075400     MOVE PLOT-TOT-HLD TO PLOT-TOT-V31.
  765. 075500     MOVE GRP-2-V31 TO GRP-2-V31-HLD.
  766. 075600     MOVE 1 TO WR-SW.
  767. 075700 620-PLOT.
  768. 075800     MOVE HGT-CLS-V21-I1 (OCC-W1, HGT-W1-RD) TO WGT-HLD.
  769. 075900     IF PLOT-W1 NOT = PLOT-HLD
  770. 076000         ADD 1 TO SUB.
  771. 076100     MOVE PLOT-W1 TO PLOT-HLD.
  772. 076200     IF SUB = 11 MOVE 1 TO SUB.
  773. 076300     MOVE WGT-HLD TO WGT-V31 (SUB).
  774. 076400     MOVE PLOT-W1 TO PLOT-V31 (SUB).
  775. 076500     MOVE AVAIL-V21-I1 (OCC-W1) TO AVAIL-V31 (SUB).
  776. 076600     MOVE PHNO-V21-I1 (OCC-W1) TO PHNO-V31 (SUB).
  777. 076700     MOVE UTIL-V21-I1 (OCC-W1) TO UTIL-V31 (SUB).
  778. 076800     IF PHNO-V31 (SUB) = "G" MOVE "6" TO PHNO-V31 (SUB).
  779. 076900     IF UTIL-V31 (SUB) = "O" MOVE "0" TO UTIL-V31 (SUB).
  780. 077000     IF AVAIL-V31 (SUB) = "D" MOVE "P" TO PHNO-V31 (SUB).
  781. 077100     IF AVAIL-V31 (SUB) = "J" MOVE "U" TO PHNO-V31 (SUB).
  782. 077200     IF AVAIL-V31 (SUB) = "E" MOVE "P" TO PHNO-V31 (SUB).
  783. 077300     IF AVAIL-V31 (SUB) = "R" MOVE "A" TO PHNO-V31 (SUB).
  784. 077400     IF (PHNO-V31 (SUB) NUMERIC) AND
  785. 077500        (UTIL-V31 (SUB) NOT NUMERIC)
  786. 077600        MOVE "0" TO UTIL-V31 (SUB).
  787. 077700     RETURN FIL-W1 AT END
  788. 077800         MOVE 1 TO END-SW
  789. 077900         GO TO 625-CK-WR.
  790. 078000     MOVE DATA-W1 TO REC-I1.
  791. 078100     IF PLANT-W1 NOT = SPACE
  792. 078200*        DISPLAY "SR= " REC-W1
  793. 078300*        DISPLAY "GOD " DATA-W1
  794. 078400         ADD 1 TO REC-CNT
  795. 078500         GO TO 600-V31.
  796. 078600 625-CK-WR.
  797. 078700     IF WR-SW = 1 MOVE ZERO TO WR-SW
  798. 078800         ADD 1 TO LINE-CNT
  799. 078900*        MOVE LINE-CNT TO LINE-V31
  800. 079000         ADD 1 TO C31O
  801. 079100         ADD 1 TO C99O
  802. 079200*        WRITE REC-P1 FROM V31
  803. 079300         WRITE REC-D1 FROM V31.
  804. 079400     GO TO 105-CK-REC.
  805. 079500 999-END.
  806. 079600 DUMMY SECTION.
  807. 000000*-----------------------------------------------------------------
  808. 000100 IDENTIFICATION DIVISION.
  809. 000200 PROGRAM-ID. ES010M.
  810. 000300*        CONVERSION OF THE VEGETATIVE RECORDS FROM 144 TO 156 CHAR
  811. 000400*
  812. 000500 AUTHOR. CHUCK SLIZEWSKI.
  813. 000600 DATE-WRITTEN.   01/10/79.
  814. 000700 DATE-COMPILED.
  815. 000800 ENVIRONMENT DIVISION.
  816. 000900 CONFIGURATION SECTION.
  817. 001000 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  818. 001100 OBJECT-COMPUTER.  LEVEL-66-ASCII.
  819. 001200 INPUT-OUTPUT SECTION.
  820. 001300 FILE-CONTROL.
  821. 001400     SELECT FIL-D1          ASSIGN TO D1
  822. 001500         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  823. 001600     SELECT FIL-D2          ASSIGN TO D2
  824. 001700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  825. 001800     SELECT FIL-I1          ASSIGN TO I1
  826. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  827. 002000     SELECT FIL-W1          ASSIGN TO W1
  828. 002100         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  829. 002200 DATA DIVISION.
  830. 002300 SUB-SCHEMA SECTION.
  831. 002400 DB  CODVAL2 WITHIN BLMDIC.
  832. 002500 FILE SECTION.
  833. 002600 FD  FIL-D1
  834. 002700     CODE-SET IS GBCD
  835. 002800     LABEL RECORDS ARE STANDARD
  836. 002900     DATA RECORD IS REC-D1.
  837. 003000 01  REC-D1  PIC X(144).
  838. 003100 FD  FIL-D2
  839. 003200     CODE-SET IS GBCD
  840. 003300     LABEL RECORDS ARE STANDARD
  841. 003400     DATA RECORD IS REC-D2.
  842. 003500 01  REC-D2  PIC X(156).
  843. 003600 FD  FIL-I1
  844. 003700     CODE-SET IS GBCD
  845. 003800     LABEL RECORDS ARE STANDARD
  846. 003900     DATA RECORD IS REC-I1.
  847. 004000 01  REC-I1.
  848. 004100     03  FILLER         PIC XXXX.
  849. 004200     03  REC-TYP-I1     PIC XXXX.
  850. 004300     03  ST-I1          PIC XX.
  851. 004400     03  DS-I1          PIC XX.
  852. 004500     03  PU-I1          PIC XX.
  853. 004600     03  FILLER         PIC X(138).
  854. 004700     03  RA-I1          PIC XX.
  855. 004800     03  PAST-I1        PIC XX.
  856. 004900 SD  FIL-W1
  857. 005000     DATA RECORD IS REC-W1.
  858. 005100 01  REC-W1.
  859. 005200     03  FILLER              PIC XXXX.
  860. 005300     03  REC-TYP-W1          PIC XX.
  861. 005400     03  FMT-NUM-W1          PIC X.
  862. 005500     03  FMT-CD-W1           PIC X.
  863. 005600     03  SDP-A-SWAT-W1.
  864. 005700         05  SDP-W1.
  865. 005800             07  ADST-DIST-CDS-W1
  866. 005900                             PIC XXXX.
  867. 006000             07  PLU-CD-W1   PIC XX.
  868. 006100         05  FILLER          PIC X(10).
  869. 006200     03  C25-T-61-W1         PIC X(37).
  870. 006300     03  C62-T-144-W1.
  871. 006400         05  HRBG-PROD-WGT-3A-W1
  872. 006500                             PIC XXXX  OCCURS 10 TIMES.
  873. 006600         05  FILLER          PIC X(43).
  874. 006700     03  C62-T-144-R1  REDEFINES  C62-T-144-W1.
  875. 006800         05  CLS-PLANT-PROD-WGT-3B-W1
  876. 006900                             PIC X(7)  OCCURS 10 TIMES.
  877. 007000         05  FILLER          PIC X(13).
  878. 007100     03  RA-I-W1             PIC XX.
  879. 007200 WORKING-STORAGE SECTION.
  880. 007300 77  REC-DEL-CNTR  PIC 9(6)  COMP-4  VALUE ZERO.
  881. 007400 77  FMT-CNT   PIC 9(6)  VALUE ZERO.
  882. 007500 77  REC-IN-CNTR  PIC 9(6)  COMP-4  VALUE ZERO.
  883. 007600 77  REC-OUT-CNTR  PIC 9(6)  COMP-4  VALUE ZERO.
  884. 007700 77  SS2A  PIC 99  COMP-4.
  885. 007800 77  LIN-NUM-H  PIC 999.
  886. 007900 77  RA-CD-H  PIC XX.
  887. 008000 01  PARAMETER.
  888. 008100     03  RFMAT-FLG    PIC XXX.
  889. 008200     03  FILLER     PIC X(77).
  890. 008300 01  REC-H1.
  891. 008400     03  C1-T-156-H1.
  892. 008500         05  C1-T-144-H1.
  893. 008600             07  FILLER          PIC XXXX.
  894. 008700             07  REC-TYP-H1      PIC XX.
  895. 008800             07  FMT-NUM-H1      PIC X.
  896. 008900             07  FMT-CD-H1       PIC X.
  897. 009000             07  SDP-A-SWAT-H1.
  898. 009100                 09  SDP-H1      PIC X(6).
  899. 009200                 09  ALLOT-H1    PIC X(04).
  900. 009300                 09  FILLER      PIC X(06).
  901. 009400             07  ACTN-CD-LIN-NUM-H1.
  902. 009500                 09  ACTN-CD-H1  PIC X.
  903. 009600                 09  LIN-NUM-H1  PIC 999.
  904. 009700             07  FILLER          PIC X(7).
  905. 009800             07  RA-CD-H1        PIC XX.
  906. 009900             07  FILLER          PIC X(107).
  907. 010000         05  FILLER              PIC X(8).
  908. 010100         05  RA-I-H1             PIC XX.
  909. 010200         05  PS-I-H1             PIC XX.
  910. 010300     03  C1-T-156-R1  REDEFINES  C1-T-156-H1.
  911. 010400         05  FILLER              PIC X(61).
  912. 010500         05  C62-T-144-H1.
  913. 010600             07  GRP-3A-H1       PIC X(6)  OCCURS 10 TIMES.
  914. 010700             07  FILLER          PIC X(35).
  915. 010800         05  C62-T-144-R1  REDEFINES  C62-T-144-H1.
  916. 010900             07  GRP-3B-H1       PIC X(9)  OCCURS 10 TIMES.
  917. 011000             07  FILLER          PIC X(5).
  918. 011100 01  HOLD-AREA.
  919. 011200     03  ADST-CD-T-FMT-NUM-H2.
  920. 011300         05  SDP-A-SWAT-H2           PIC X(16).
  921. 011400         05  REC-TYP-H2             PIC XX.
  922. 011500         05  FMT-CD-H2  PIC X.
  923. 011600         05  FMT-NUM-H2  PIC X.
  924. 011700     03  ADST-CD-T-FMT-NUM-H3  PIC X(20)  VALUE SPACES.
  925. 011800     03  GRP-3A-H2.
  926. 011900         05  PLOT-NUM-3A-H2  PIC 99.
  927. 012000         05  PLOT-NUM-3A-R2  REDEFINES  PLOT-NUM-3A-H2  PIC XX.
  928. 012100         05  HRBG-PROD-WGT-3A-H2  PIC XXXX.
  929. 012200     03  GRP-3B-H2.
  930. 012300         05  PLOT-NUM-3B-H2  PIC 99.
  931. 012400         05  PLOT-NUM-3B-R2  REDEFINES  PLOT-NUM-3B-H2  PIC XX.
  932. 012500         05  CLS-PLANT-PROD-WGT-3B-H2  PIC X(7).
  933. 012600     03  ADST-DIST-RA-PLU-CDS-H3.
  934. 012700         07  ADST-DIST-CDS-H3  PIC XXXX.
  935. 012800         07  RA-CD-H3.
  936. 012900             09  RA-CD-C1-H3  PIC 9.
  937. 013000             09  FILLER  PIC 9  VALUE 8.
  938. 013100         07  PLU-CD-H3  PIC XX.
  939. 013200 PROCEDURE DIVISION.
  940. 013300 SS SECTION.
  941. 013400 SSP.
  942. 013500     SORT FIL-W1 ON ASCENDING KEY SDP-A-SWAT-W1,
  943. 013600                                  REC-TYP-W1,
  944. 013700                                  FMT-CD-W1,
  945. 013800                                  FMT-NUM-W1,
  946. 013900                                  C25-T-61-W1,
  947. 014000                                  C62-T-144-W1,
  948. 014100         INPUT  PROCEDURE IS IN-PROC,
  949. 014200         OUTPUT PROCEDURE IS OT-PROC.
  950. 014300 IN-PROC SECTION.
  951. 014400 IPP.
  952. 014500     ACCEPT PARAMETER.
  953. 014600     OPEN INPUT  FIL-I1,
  954. 014700          OUTPUT FIL-D2.
  955. 014800 0100.
  956. 014900     READ FIL-I1  AT END  GO TO 0900.
  957. 015000     ADD 1 TO FMT-CNT.
  958. 015100     IF FMT-CNT < 10 DISPLAY "REC-I1= " REC-I1.
  959. 015200     ADD 1 TO REC-IN-CNTR.
  960. 015300*    MOVE REC-I1 TO REC-H1.  MOVE "A" TO ACTN-CD-H1.
  961. 015400     MOVE REC-I1 TO REC-H1.  MOVE "A   " TO ACTN-CD-LIN-NUM-H1.
  962. 015500     IF FMT-CNT < 10 DISPLAY "REC-H1= " REC-H1.
  963. 015600     MOVE C1-T-144-H1 TO REC-W1.
  964. 015700     MOVE RA-I-H1 TO RA-I-W1.
  965. 015800     IF FMT-CNT < 10 DISPLAY "REC-W1= " REC-W1.
  966. 015900     IF REC-TYP-H1 NOT = "V3" GO TO 0800.
  967. 016000     IF RFMAT-FLG NOT = "YES" GO TO 0800.
  968. 016100     MOVE SPACES TO C62-T-144-W1.  MOVE 1 TO SS2A.
  969. 016200     IF FMT-CD-H1 = "B"  GO TO 0500.
  970. 016300     IF FMT-CD-H1 NOT = "A"
  971. 016400         MOVE REC-I1 TO REC-D2  WRITE REC-D2
  972. 016500         DISPLAY "     BAD FORMAT CODE", DISPLAY REC-I1
  973. 016600         DISPLAY SPACE  GO TO 0100.
  974. 016700 0200.
  975. 016800     MOVE GRP-3A-H1 (SS2A) TO GRP-3A-H2.
  976. 016900     IF GRP-3A-H2 = SPACES  GO TO 0400.
  977. 017000     IF PLOT-NUM-3A-H2 ZERO OR PLOT-NUM-3A-R2 NOT NUMERIC
  978. 017100         MOVE REC-I1 TO REC-D2  WRITE REC-D2
  979. 017200         DISPLAY "     BAD PLOT NUMBER", DISPLAY REC-I1
  980. 017300         DISPLAY SPACE  GO TO 0100.
  981. 017400 0300.
  982. 017500     IF PLOT-NUM-3A-H2 > 10
  983. 017600         SUBTRACT 10 FROM PLOT-NUM-3A-H2  GO TO 0300.
  984. 017700     MOVE HRBG-PROD-WGT-3A-H2
  985. 017800         TO HRBG-PROD-WGT-3A-W1 (PLOT-NUM-3A-H2).
  986. 017900 0400.
  987. 018000     IF SS2A < 10  ADD 1 TO SS2A  GO TO 0200.  GO TO 0800.
  988. 018100 0500.
  989. 018200     MOVE GRP-3B-H1 (SS2A) TO GRP-3B-H2.
  990. 018300     IF GRP-3B-H2 = SPACES  GO TO 0700.
  991. 018400     IF PLOT-NUM-3B-H2 ZERO OR PLOT-NUM-3B-R2 NOT NUMERIC
  992. 018500         MOVE REC-I1 TO REC-D2  WRITE REC-D2
  993. 018600         DISPLAY "     BAD PLOT NUMBER", DISPLAY REC-I1
  994. 018700         DISPLAY SPACE  GO TO 0100.
  995. 018800 0600.
  996. 018900     IF PLOT-NUM-3B-H2 > 10
  997. 019000         SUBTRACT 10 FROM PLOT-NUM-3B-H2  GO TO 0600.
  998. 019100     MOVE CLS-PLANT-PROD-WGT-3B-H2
  999. 019200         TO CLS-PLANT-PROD-WGT-3B-W1 (PLOT-NUM-3B-H2).
  1000. 019300 0700.
  1001. 019400     IF SS2A < 10  ADD 1 TO SS2A  GO TO 0500.
  1002. 019500 0800.
  1003. 019600     RELEASE REC-W1.  GO TO 0100.
  1004. 019700 0900.
  1005. 019800     CLOSE FIL-I1.
  1006. 019900 OT-PROC SECTION.
  1007. 020000 OPP.
  1008. 020100     OPEN OUTPUT FIL-D1.  READY DIC-DE.
  1009. 020200     MOVE ZERO TO FMT-CNT.
  1010. 020300     MOVE SPACES TO SDP-H1.
  1011. 020400 1000-RETURN.
  1012. 020500     RETURN FIL-W1  AT END
  1013. 020600         DISPLAY "TOTAL RECORDS IN      = ", REC-IN-CNTR
  1014. 020700         DISPLAY "TOTAL RECORDS DELETED = ", REC-DEL-CNTR
  1015. 020800         DISPLAY "TOTAL RECORDS OUT     = ", REC-OUT-CNTR
  1016. 020900         CLOSE FIL-D1, FIL-D2  FINISH DIC-DE  STOP RUN.
  1017. 021000     ADD 1 TO FMT-CNT.
  1018. 021100     IF FMT-CNT < 10 DISPLAY "REC-W1= " REC-W1.
  1019. 021200     IF C1-T-144-H1 = REC-W1  DISPLAY SPACE
  1020. 021300         DISPLAY C1-T-144-H1  DISPLAY REC-W1
  1021. 021400         ADD 1 TO REC-DEL-CNTR  GO TO 1000-RETURN.
  1022. 021500     IF SDP-H1 = SDP-W1
  1023. 021600         GO TO 1200-WRITE.
  1024. 021700     MOVE ADST-DIST-CDS-W1 TO ADST-DIST-CDS-H3.
  1025. 021800     MOVE RA-I-W1 TO RA-CD-H.
  1026. 021900     MOVE 4 TO RA-CD-C1-H3.  MOVE PLU-CD-W1 TO PLU-CD-H3.
  1027. 022000     MOVE 0003 TO DE-NO-8801-DEC.
  1028. 022100     GO TO 1200-WRITE.
  1029. 022200 1100-FIND-RA.
  1030. 022300     MOVE ADST-DIST-RA-PLU-CDS-H3 TO DE-CD-8822-DEC.
  1031. 022400     FIND ANY CODE-DEC.
  1032. 022500     IF DB-STATUS = ZERO
  1033. 022600         MOVE RA-CD-H3 TO RA-CD-H  GO TO 1200-WRITE.
  1034. 022700     IF RA-CD-C1-H3 < 8 ADD 1 TO RA-CD-C1-H3
  1035. 022800         GO TO 1100-FIND-RA.
  1036. 022900     MOVE REC-W1 TO REC-D2.  WRITE REC-D2.
  1037. 023000     DISPLAY "     BAD STATE, DISTRICT, PLANNING UNIT CODES".
  1038. 023100     DISPLAY REC-W1.  DISPLAY SPACE.  GO TO 1000-RETURN.
  1039. 023200 1200-WRITE.
  1040. 023300     IF FMT-CNT < 10 DISPLAY "REC-W1= " REC-I1.
  1041. 023400     MOVE REC-W1 TO C1-T-144-H1.
  1042. 023500     IF FMT-CNT < 10 DISPLAY "REC-H1= " REC-H1.
  1043. 023600     MOVE SDP-A-SWAT-H1 TO SDP-A-SWAT-H2.
  1044. 023700     MOVE REC-TYP-H1 TO REC-TYP-H2.
  1045. 023800     MOVE FMT-CD-H1 TO FMT-CD-H2.
  1046. 023900     MOVE FMT-NUM-H1 TO FMT-NUM-H2.
  1047. 024000     IF ADST-CD-T-FMT-NUM-H2 NOT = ADST-CD-T-FMT-NUM-H3
  1048. 024100         MOVE ADST-CD-T-FMT-NUM-H2 TO ADST-CD-T-FMT-NUM-H3
  1049. 024200         MOVE ZERO TO LIN-NUM-H.  ADD 1 TO LIN-NUM-H.
  1050. 024300     MOVE LIN-NUM-H TO LIN-NUM-H1.
  1051. 024400     MOVE RA-CD-H TO RA-CD-H1.  MOVE C1-T-144-H1 TO REC-D1.
  1052. 024500     IF FMT-CNT < 10 DISPLAY "HLD-AR= " HOLD-AREA.
  1053. 024600     IF FMT-CNT < 10 DISPLAY "REC-D1= " REC-D1.
  1054. 024700     WRITE REC-D1.  ADD 1 TO REC-OUT-CNTR.  GO TO 1000-RETURN.
  1055. 000000*-----------------------------------------------------------------
  1056. 000100 IDENTIFICATION DIVISION.
  1057. 000200 PROGRAM-ID. ES021P.
  1058. 000300*        VEGETATIVE VERIFICATION LISTING
  1059. 000400*
  1060. 000500 AUTHOR. CHUCK SLIZEWSKI.
  1061. 000500 DATE-WRITTEN.   01/10/79.
  1062. 000600 DATE-COMPILED.
  1063. 000700 ENVIRONMENT DIVISION.
  1064. 000800 CONFIGURATION SECTION.
  1065. 000900 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  1066. 001000 OBJECT-COMPUTER.  LEVEL-66-ASCII.
  1067. 001100 INPUT-OUTPUT SECTION.
  1068. 001200 FILE-CONTROL.
  1069. 001300     SELECT FIL-I1    ASSIGN TO I1
  1070. 001400         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  1071. 001500     SELECT FIL-P1    ASSIGN TO P1
  1072. 001600         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  1073. 001700 DATA DIVISION.
  1074. 001800 SUB-SCHEMA SECTION.
  1075. 001900 DB CODVAL2 WITHIN BLMDIC.
  1076. 002000 FILE SECTION.
  1077. 002100 FD  FIL-I1
  1078. 002200     CODE-SET IS GBCD
  1079. 002300     LABEL RECORDS ARE STANDARD
  1080. 002400     DATA RECORD IS REC-I1.
  1081. 002500 01  REC-I1  PIC X(144).
  1082. 002600 FD  FIL-P1
  1083. 002700     CODE-SET IS GBCD
  1084. 002800     LABEL RECORDS ARE STANDARD
  1085. 002900     DATA RECORD IS REC-P1.
  1086. 003000 01  REC-P1  PIC X(132).
  1087. 003100 WORKING-STORAGE SECTION.
  1088. 003200 77  LIN-CHK  PIC 99  COMP-4.
  1089. 003300 77  IN-CNTR  PIC 9(6)  COMP-4  VALUE ZERO.
  1090. 003400 77  LIN-CNTR  PIC 99  COMP-4.
  1091. 003500 77  PAG-CNTR  PIC 9999  COMP-4  VALUE ZERO.
  1092. 003600 77  RITE-HDR-FLG  PIC 9  COMP-4.
  1093. 003700 77  RITE-KEY-FLG  PIC 9  COMP-4.
  1094. 003800 77  SS1A  PIC 9  COMP-4.
  1095. 003900 77  SS1B  PIC 9  COMP-4.
  1096. 004000 77  SS1C  PIC 9  COMP-4.
  1097. 004100 77  SS1D  PIC 9  COMP-4.
  1098. 004200 77  SS2A  PIC 99  COMP-4.
  1099. 004300 01  COL-HDR1A.
  1100. 004400     03  FILLER  PIC X(24)  VALUE "          ST   DIST   PL".
  1101. 004500     03  FILLER  PIC X(24)  VALUE "U   ALLOT   SWA     TRN ".
  1102. 004600     03  FILLER  PIC X(84)  VALUE SPACES.
  1103. 004700 01  COL-HDR1B.
  1104. 004800     03  FILLER  PIC X(24)  VALUE "         9-10  11-12 13-".
  1105. 004900     03  FILLER  PIC X(24)  VALUE "14  15-18   19-22  23-24".
  1106. 005000     03  FILLER  PIC X(84)  VALUE SPACES.
  1107. 005100 01  COL-HDR1C.
  1108. 005200     03  FILLER  PIC X(24)  VALUE "          XX    XX    XX".
  1109. 005300     03  FILLER  PIC X(24)  VALUE "    XXXX    XXXX    XX  ".
  1110. 005400     03  FILLER  PIC X(84)  VALUE SPACES.
  1111. 005500 01  COL-HDRA11  PIC X(108)  VALUE "O SWA/T  RNG SITE    CC  VEG S
  1112. 005600-                        "-TYP  % SWA  DATE    RECR      A/PHOTO
  1113. 005700-                        "CMPR: ST   DIST   TWP   RNG     NUM   ".
  1114. 005800 01  COL-HDRB11  PIC X(108)  VALUE "30-35     45-55      56    57-
  1115. 005900-                        "60    61-63  64-69   70-72      73-88
  1116. 006000-                        "     89-90 91-92 93-97 98-102 103-104 ".
  1117. 006100 01  COL-HDRC11  PIC X(108)  VALUE "XXXXXX  XXXXXXXXXXX  X     XXX
  1118. 006200-                        "X      XXX   XXXXXX   XXX  XXXXXXXXXXXXX
  1119. 006300-                        "XXX   XX    XX   XXXXX XXXXX    XX    ".
  1120. 006400 01  COL-HDRA12  PIC X(108)  VALUE "GRND CVR BASAL  NUM    - - - -
  1121. 006500-                        " -O B S E R V E D   S P E C I E S- - - -
  1122. 006600-                        " -                                    ".
  1123. 006700 01  COL-HDRB12  PIC X(108)  VALUE "   DATA:  45   46-48    49-55
  1124. 006800-                        "        56-62         63-69         70-7
  1125. 006900-                        "6                                     ".
  1126. 007000 01  COL-HDRC12  PIC X(108)  VALUE "          X     XXX    XXXXXXX
  1127. 007100-                        "       XXXXXXX       XXXXXXX       XXXXX
  1128. 007200-                        "XX                                    ".
  1129. 007300 01  COL-HDRA13  PIC X(108)  VALUE "  BASAL    CANOPY 1   CANOPY 2
  1130. 007400-                        "   CANOPY 3   NUM      BASAL    CANOPY 1
  1131. 007500-                        "   CANOPY 2   CANOPY 3   NUM          ".
  1132. 007600 01  COL-HDRB13  PIC X(108)  VALUE "  45-53     54-62      63-71
  1133. 007700-                        "    72-80    81-83     84-92     93-101
  1134. 007800-                        "   102-110    111-119  120-122        ".
  1135. 007900 01  COL-HDRC13  PIC X(108)  VALUE "XXXXXXXXX  XXXXXXXXX  XXXXXXXX
  1136. 008000-                        "X  XXXXXXXXX  XXX    XXXXXXXXX  XXXXXXXX
  1137. 008100-                        "X  XXXXXXXXX  XXXXXXXXX  XXX          ".
  1138. 008200 01  COL-HDRA14  PIC X(108)  VALUE "SOIL MVMT  SOIL LITR  SURF ROC
  1139. 008300-                        "K  PEDESTALL  FLOW PTRN    RILLS     GUL
  1140. 008400-                        "LIES                                  ".
  1141. 008500 01  COL-HDRB14  PIC X(108)  VALUE "  45-46      47-48      49-50
  1142. 008600-                        "     51-52      53-54      55-56      57
  1143. 008700-                        "-58                                   ".
  1144. 008800 01  COL-HDRC14  PIC X(108)  VALUE "   XX         XX         XX
  1145. 008900-                        "      XX         XX         XX         X
  1146. 009000-                        "X                                     ".
  1147. 009100 01  COL-HDRA21  PIC X(108)  VALUE "SIZ/PLOT/NUM   SPECIES  AGE/CL
  1148. 009200-                        "ASS/FORM  PHNO  AVAIL  UTIL  HGT   D/CNT
  1149. 009300-                        "  L/LGT  CROWN DIA  N/CHARZD  M/CROPS ".
  1150. 009400 01  COL-HDRB21  PIC X(108)  VALUE "45      46-47   48-54   55
  1151. 009500-                        "     56    57    58     59  60-64  65-67
  1152. 009600-                        "  68-72    73-77     78-80      81    ".
  1153. 009700 01  COL-HDRC21  PIC X(108)  VALUE " X       XX    XXXXXXX   X
  1154. 009800-                        "     X     X      X     X   XXX XX  XXX
  1155. 009900-                        "  XXX XX   XXX XX     XXX        X    ".
  1156. 010000 01  COL-HDRA3A  PIC X(108)  VALUE " NUM/PLOT/SIZ    SPECIES  HGT
  1157. 010100-                        " WGT-EXT   1      2      3      4      5
  1158. 010200-                        "      6      7      8      9     10   ".
  1159. 010300 01  COL-HDRB3A  PIC X(108)  VALUE "45-46    47-53    54-60   61
  1160. 010400-                        "   DATA: 62-65  66-69  70-73  74-77  78-
  1161. 010500-                        "81  82-85  86-89  90-93  94-97 98-101 ".
  1162. 010600 01  COL-HDRC3A  PIC X(108)  VALUE " XX    XXXXX XX  XXXXXXX   X
  1163. 010700-                        "         XXXX   XXXX   XXXX   XXXX   XXX
  1164. 010800-                        "X   XXXX   XXXX   XXXX   XXXX   XXXX  ".
  1165. 010900 01  COL-HDRA3B  PIC X(108)  VALUE "NUM/PLOT/SIZ SPECIES HGT WE
  1166. 011000-                        " 1       2       3       4       5
  1167. 011100-                        " 6       7       8       9      10    ".
  1168. 011200 01  COL-HDRB3B  PIC X(108)  VALUE "45-46 47-53   54-60  61  D:  6
  1169. 011300-                        "2-68   69-75   76-82   83-89   90-96  97
  1170. 011400-                        "-103  104-110 111-117 118-124 125-131 ".
  1171. 011500 01  COL-HDRC3B  PIC X(108)  VALUE " XX XXXXX XX XXXXXXX  X     XX
  1172. 011600-                        "XXXXX XXXXXXX XXXXXXX XXXXXXX XXXXXXX XX
  1173. 011700-                        "XXXXX XXXXXXX XXXXXXX XXXXXXX XXXXXXX ".
  1174. 011800 01  COL-HDR2A.
  1175. 011900     03  FILLER  PIC X(24)  VALUE "REC TYP  ACTN  LIN NUM  ".
  1176. 012000     03  COL-HDR2A1  PIC X(108).
  1177. 012100 01  COL-HDR2B.
  1178. 012200     03  FILLER  PIC X(24)  VALUE " 5-8      25    26-28   ".
  1179. 012300     03  COL-HDR2B1  PIC X(108).
  1180. 012400 01  COL-HDR2C.
  1181. 012500     03  FILLER  PIC X(24)  VALUE " XXXX     X      XXX    ".
  1182. 012600     03  COL-HDR2C1  PIC X(108).
  1183. 012700 01  DATA-LIN1A  VALUE SPACES.
  1184. 012800     03  FILLER  PIC X.
  1185. 012900     03  REC-TYP-T-FMT-CD-DL1A.
  1186. 013000         05  FILLER  PIC XX.
  1187. 013100         05  FMT-NUM-DL1A  PIC X.
  1188. 013200         05  FILLER  PIC X.
  1189. 013300     03  FILLER  PIC X(5).
  1190. 013400     03  ACTN-CD-DL1A  PIC X.
  1191. 013500     03  FILLER  PIC X(6).
  1192. 013600     03  LIN-NUM-DL1A  PIC XXX.
  1193. 013700     03  FILLER  PIC XXXX.
  1194. 013800     03  DATA-LIN1A11.
  1195. 013900         05  SWA-BRWD-DL1A11  PIC X(6).
  1196. 014000         05  FILLER  PIC XX.
  1197. 014100         05  RNG-SITE-ID-DL1A11  PIC X(11).
  1198. 014200         05  FILLER  PIC XX.
  1199. 014300         05  RNG-ECOL-COND-CLS-DL1A11  PIC X.
  1200. 014400         05  FILLER  PIC X(5).
  1201. 014500         05  VEG-SUB-TYP-DL1A11  PIC XXXX.
  1202. 014600         05  FILLER  PIC X(6).
  1203. 014700         05  SWA-PCT-DL1A11  PIC XXX.
  1204. 014800         05  FILLER  PIC XXX.
  1205. 014900         05  DATA-DAT-DL1A11  PIC X(6).
  1206. 015000         05  FILLER  PIC XXX.
  1207. 015100         05  RECER-INTLS-DL1A11  PIC XXX.
  1208. 015200         05  FILLER  PIC XX.
  1209. 015300         05  PHOTO-ID-DL1A11  PIC X(16).
  1210. 015400         05  FILLER  PIC XXX.
  1211. 015500         05  ADST-CD-CMPR-DL1A11  PIC XX.
  1212. 015600         05  FILLER  PIC XXXX.
  1213. 015700         05  DIST-CD-CMPR-DL1A11  PIC XX.
  1214. 015800         05  FILLER  PIC XXX.
  1215. 015900         05  TWP-CMPR-DL1A11  PIC X(5).
  1216. 016000         05  FILLER  PIC X.
  1217. 016100         05  RNG-CMPR-DL1A11  PIC X(5).
  1218. 016200         05  FILLER  PIC XXXX.
  1219. 016300         05  CONS-NUM-CMPR-DL1A11  PIC XX.
  1220. 016400         05  FILLER  PIC XXXX.
  1221. 016500     03  DATA-LIN1A12  REDEFINES  DATA-LIN1A11.
  1222. 016600         05  FILLER  PIC X(10).
  1223. 016700         05  TYP-GC-CD-DL1A12  PIC X.
  1224. 016800         05  FILLER  PIC X(5).
  1225. 016900         05  TYP-GC-HITS-DL1A12  PIC XXX.
  1226. 017000         05  FILLER  PIC XXXX.
  1227. 017100         05  GRP-DL1A12  OCCURS 4 TIMES.
  1228. 017200             07  PLANT-CD-DL1A12  PIC X(7).
  1229. 017300             07  FILLER  PIC X(7).
  1230. 017400         05  FILLER  PIC X(29).
  1231. 017500     03  DATA-LIN1A13  REDEFINES  DATA-LIN1A11.
  1232. 017600         05  GRP1-DL1A13  OCCURS 2 TIMES.
  1233. 017700             07  GRP2-DL1A13  OCCURS 4 TIMES.
  1234. 017800                 09  PLANT-CD-DL1A13  PIC X(9).
  1235. 017900                 09  FILLER  PIC XX.
  1236. 018000             07  TYP-GC-HITS-DL1A13  PIC XXX.
  1237. 018100             07  FILLER  PIC XXXX.
  1238. 018200         05  FILLER  PIC X(6).
  1239. 018300     03  DATA-LIN1A14  REDEFINES  DATA-LIN1A11.
  1240. 018400         05  FILLER  PIC XXX.
  1241. 018500         05  GRP-DL1A14  OCCURS 7 TIMES.
  1242. 018600             07  SSF-VAL-RAT-DL1A14  PIC XX.
  1243. 018700             07  FILLER  PIC X(9).
  1244. 018800         05  FILLER  PIC X(28).
  1245. 018900     03  DATA-LIN1A21  REDEFINES  DATA-LIN1A11.
  1246. 019000         05  FILLER  PIC X.
  1247. 019100         05  PLOT-SIZ-DL1A21  PIC X.
  1248. 019200         05  FILLER  PIC X(7).
  1249. 019300         05  PLOT-NUM-DL1A21  PIC XX.
  1250. 019400         05  FILLER  PIC XXXX.
  1251. 019500         05  PLANT-CD-DL1A21  PIC X(7).
  1252. 019600         05  FILLER  PIC XXX.
  1253. 019700         05  AGE-CLS-PLANT-DL1A21  PIC X.
  1254. 019800         05  FILLER  PIC X(9).
  1255. 019900         05  FORM-CLS-PLANT-DL1A21  PIC X.
  1256. 020000         05  FILLER  PIC X(5).
  1257. 020100         05  PHNO-STG-DL1A21  PIC X.
  1258. 020200         05  FILLER  PIC X(6).
  1259. 020300         05  CLS-PLANT-AVAIL-DL1A21  PIC X.
  1260. 020400         05  FILLER  PIC X(5).
  1261. 020500         05  CLS-PLANT-UTIL-DL1A21  PIC X.
  1262. 020600         05  FILLER  PIC XXX.
  1263. 020700         05  AVG-HGT-PLANT-INGR-DL1A21  PIC XXX.
  1264. 020800         05  AVG-HGT-PLANT-DEC-DL1A21  PIC X.
  1265. 020900         05  AVG-HGT-PLANT-FRC-DL1A21  PIC XX.
  1266. 021000         05  FILLER  PIC XX.
  1267. 021100         05  CHARZD-NUM-DL1A21  PIC XXX.
  1268. 021200         05  FILLER  PIC XXX.
  1269. 021300         05  AVG-LDR-LGT-INGR-DL1A21  PIC XXX.
  1270. 021400         05  AVG-LDR-LGT-DEC-DL1A21  PIC X.
  1271. 021500         05  AVG-LDR-LGT-FRC-DL1A21  PIC XX.
  1272. 021600         05  FILLER  PIC XXX.
  1273. 021700         05  AVG-CRN-DIA-INGR-DL1A21  PIC XXX.
  1274. 021800         05  AVG-CRN-DIA-DEC-DL1A21  PIC X.
  1275. 021900         05  AVG-CRN-DIA-FRC-DL1A21  PIC XX.
  1276. 022000         05  FILLER  PIC X(5).
  1277. 022100         05  CHARZD-NOT-NUM-DL1A21  PIC XXX.
  1278. 022200         05  FILLER  PIC X(8).
  1279. 022300         05  MAST-CROPS-CD-DL1A21  PIC X.
  1280. 022400         05  FILLER  PIC XXXX.
  1281. 022500     03  DATA-LIN1A3A  REDEFINES  DATA-LIN1A11.
  1282. 022600         05  FILLER  PIC X.
  1283. 022700         05  PLOT-TOT-NUM-DL1A3A  PIC XX.
  1284. 022800         05  FILLER  PIC XXXX.
  1285. 022900         05  PLOT-SIZ-EST-INGR-DL1A3A  PIC X(5).
  1286. 023000         05  PLOT-SIZ-EST-DEC-DL1A3A  PIC X.
  1287. 023100         05  PLOT-SIZ-EST-FRC-DL1A3A  PIC XX.
  1288. 023200         05  FILLER  PIC XX.
  1289. 023300         05  PLANT-CD-DL1A3A  PIC X(7).
  1290. 023400         05  FILLER  PIC XXX.
  1291. 023500         05  HGT-CLS-CD-DL1A3A  PIC X.
  1292. 023600         05  FILLER  PIC X(10).
  1293. 023700         05  GRP-DL1A3A  OCCURS 10 TIMES.
  1294. 023800             07  FILLER  PIC X.
  1295. 023900             07  HRBG-PROD-WGT-DL1A3A  PIC XXXX.
  1296. 024000             07  FILLER  PIC XX.
  1297. 024100     03  DATA-LIN1A3B  REDEFINES  DATA-LIN1A11.
  1298. 024200         05  FILLER  PIC X.
  1299. 024300         05  PLOT-TOT-NUM-DL1A3B  PIC XX.
  1300. 024400         05  FILLER  PIC X.
  1301. 024500         05  PLOT-SIZ-EST-INGR-DL1A3B  PIC X(5).
  1302. 024600         05  PLOT-SIZ-EST-DEC-DL1A3B  PIC X.
  1303. 024700         05  PLOT-SIZ-EST-FRC-DL1A3B  PIC XX.
  1304. 024800         05  FILLER  PIC X.
  1305. 024900         05  PLANT-CD-DL1A3B  PIC X(7).
  1306. 025000         05  FILLER  PIC XX.
  1307. 025100         05  HGT-CLS-CD-DL1A3B  PIC X.
  1308. 025200         05  FILLER  PIC X(5).
  1309. 025300         05  GRP1-DL1A3B  OCCURS 10 TIMES.
  1310. 025400             07  GRP2-DL1A3B  PIC X(7).
  1311. 025500             07  FILLER  PIC X.
  1312. 025600 01  HOLD-AREA.
  1313. 025700     03  ADST-CD-T-TRN-NUM-H  PIC X(16)  VALUE SPACES.
  1314. 025800     03  ADST-CD-T-TRN-NUM-D11H.
  1315. 025900         05  ADST-CD-D11H  PIC XX  VALUE SPACES.
  1316. 026000         05  DIST-CD-D11H  PIC XX.
  1317. 026100         05  PLU-CD-D11H  PIC XX.
  1318. 026200         05  ALLOT-NUM-D11H  PIC XXXX.
  1319. 026300         05  SWA-CD-D11H  PIC XXXX.
  1320. 026400         05  TRN-NUM-D11H  PIC XX.
  1321. 026500     03  ADST-INV-NAM-H.
  1322. 026600         05  ADST-NAM-H  PIC X(10).
  1323. 026700         05  INV-NAM-H  PIC X(30).
  1324. 026800     03  DAT-H.
  1325. 026900         05  YER-H  PIC XX.
  1326. 027000         05  MON-H  PIC 99.
  1327. 027100         05  DAY-H  PIC XX.
  1328. 027200 01  KEY-LIN1A.
  1329. 027300     03  FILLER  PIC X(10)  VALUE SPACES.
  1330. 027400     03  ADST-CD-KL1A  PIC XX.
  1331. 027500     03  FILLER  PIC XXXX  VALUE SPACES.
  1332. 027600     03  DIST-CD-KL1A  PIC XX.
  1333. 027700     03  FILLER  PIC XXXX  VALUE SPACES.
  1334. 027800     03  PLU-CD-KL1A  PIC XX.
  1335. 027900     03  FILLER  PIC XXXX  VALUE SPACES.
  1336. 028000     03  ALLOT-NUM-KL1A  PIC XXXX.
  1337. 028100     03  FILLER  PIC XXXX  VALUE SPACES.
  1338. 028200     03  SWA-CD-KL1A  PIC XXXX.
  1339. 028300     03  FILLER  PIC XXXX  VALUE SPACES.
  1340. 028400     03  TRN-NUM-KL1A  PIC XX.
  1341. 028500     03  FILLER  PIC X(86)  VALUE SPACES.
  1342. 028600 01  PAG-HDR1.
  1343. 028700     03  FILLER  PIC XXXX  VALUE SPACES.
  1344. 028800     03  MON-PH1  PIC XXX.
  1345. 028900     03  FILLER  PIC X  VALUE SPACE.
  1346. 029000     03  DAY-PH1  PIC XX.
  1347. 029100     03  FILLER  PIC XXXX  VALUE ", 19".
  1348. 029200     03  YER-PH1  PIC XX.
  1349. 029300     03  FILLER  PIC X(26)  VALUE SPACES.
  1350. 029400     03  FILLER  PIC X(49)  VALUE "USDI - BUR OF LAND MGT  ECOLOGI
  1351. 029500-                                 "CAL SITE INVENTORY".
  1352. 029600     03  FILLER  PIC X(26)  VALUE SPACES.
  1353. 029700     03  FILLER  PIC X(06)  VALUE "PAGE: ".
  1354. 029800     03  PAG-CNT-PH1  PIC ZZ,ZZ9.
  1355. 029900     03  FILLER  PIC X(03)  VALUE SPACES.
  1356. 030000 01  PAG-HDR2.
  1357. 030100     03  FILLER  PIC X(7)  VALUE "STATE: ".
  1358. 030200     03  STATE-HDR  PIC X(10).
  1359. 030300     03  FILLER  PIC X(8)  VALUE "   INV: ".
  1360. 030400     03  INVEN-CD-HDR  PIC XXXX.
  1361. 030500     03  FILLER  PIC XXXXX  VALUE "  -  ".
  1362. 030600     03  INVENTORY-HDR  PIC X(20).
  1363. 030700     03  FILLER  PIC X(4)  VALUE SPACES.
  1364. 030800     03  FILLER  PIC X(42)  VALUE "V1, V2, V3 VERIFICATION LIST -
  1365. 030900-                                 "PCN: ES021P".
  1366. 031000     03  FILLER  PIC X(32)  VALUE SPACES.
  1367. 031100 01  REC-H1.
  1368. 031200     03  FILLER  PIC X(8)  VALUE "0000V00A".
  1369. 031300     03  ADST-CD-T-TRN-NUM-H1  PIC X(16).
  1370. 031400     03  FILLER  PIC X(120).
  1371. 031500 01  TABL-AREA.
  1372. 031600     03  MON-V  PIC X(36)  VALUE   "JANFEBMARAPRMAYJUNJULAUGSEPOCT
  1373. 031700-                                  "NOVDEC".
  1374. 031800     03  MON-T  REDEFINES  MON-V  PIC XXX  OCCURS 12 TIMES.
  1375. 031900 01  D11X.
  1376. 032000     03  BATCH-NUM-D11X  PIC XXXX.
  1377. 032100     03  REC-TYP-T-FMT-CD-D11X.
  1378. 032200         05  REC-TYP-D11X  PIC XX.
  1379. 032300         05  FMT-NUM-D11X  PIC X.
  1380. 032400         05  FMT-CD-D11X  PIC X.
  1381. 032500     03  ADST-CD-T-TRN-NUM-D11X.
  1382. 032600         05  ADST-DIST-PLU-CDS-D11X  PIC X(6).
  1383. 032700         05  ALLOT-NUM-T-TRN-NUM-D11X  PIC X(10).
  1384. 032800     03  ACTN-CD-D11X  PIC X.
  1385. 032900     03  LIN-NUM-D11X  PIC XXX.
  1386. 033000     03  FILLER  PIC X.
  1387. 033100     03  SWA-BRWD-D11X.
  1388. 033200         05  SWA-CD-BRWD-D11X  PIC X.
  1389. 033300         05  SWA-NUM-BRWD-D11X  PIC XXX.
  1390. 033400         05  TRN-NUM-BRWD-D11X  PIC XX.
  1391. 033500     03  FILLER  PIC X(9).
  1392. 033600     03  D11AX.
  1393. 033700         05  RNG-SITE-ID-D11AX  PIC X(11).
  1394. 033800         05  RNG-ECOL-COND-CLS-D11AX  PIC X.
  1395. 033900         05  VEG-SUB-TYP-D11AX  PIC XXXX.
  1396. 034000         05  SWA-PCT-D11AX  PIC XXX.
  1397. 034100         05  DATA-DAT-D11AX.
  1398. 034200             07  DATA-YER-D11AX  PIC XX.
  1399. 034300             07  DATA-MON-D11AX  PIC XX.
  1400. 034400             07  DATA-DAY-D11AX  PIC XX.
  1401. 034500         05  RECER-INTLS-D11AX  PIC XXX.
  1402. 034600         05  PHOTO-ID-D11AX  PIC X(16).
  1403. 034700         05  CMPR-ID-D11AX.
  1404. 034800             07  ADST-DIST-CDS-CMPR-D11AX.
  1405. 034900                 09  ADST-CD-CMPR-D11AX  PIC XX.
  1406. 035000                 09  DIST-CD-CMPR-D11AX  PIC XX.
  1407. 035100             07  TWP-CMPR-D11AX.
  1408. 035200                 09  TWP-NUM-CMPR-D11AX  PIC XXX.
  1409. 035300                 09  TWP-FRC-CMPR-D11AX  PIC X.
  1410. 035400                 09  TWP-DIR-CMPR-D11AX  PIC X.
  1411. 035500             07  RNG-CMPR-D11AX.
  1412. 035600                 09  RNG-NUM-CMPR-D11AX  PIC XXX.
  1413. 035700                 09  RNG-FRC-CMPR-D11AX  PIC X.
  1414. 035800                 09  RNG-DIR-CMPR-D11AX  PIC X.
  1415. 035900             07  CONS-NUM-CMPR-D11AX  PIC XX.
  1416. 036000         05  FILLER  PIC X(40).
  1417. 036100     03  D12AX  REDEFINES  D11AX.
  1418. 036200         05  TYP-GC-CD-D12AX  PIC X.
  1419. 036300         05  TYP-GC-HITS-D12AX  PIC XXX.
  1420. 036400         05  PLANT-CD-D12AX  PIC X(7)  OCCURS 4 TIMES.
  1421. 036500         05  FILLER  PIC X(68).
  1422. 036600     03  D13AX  REDEFINES  D11AX.
  1423. 036700         05  GRP1-D13AX.
  1424. 036800             07  FILLER  PIC X(39).
  1425. 036900             07  PLANT-CDS-TYP-GC-HITS-D13AX  PIC X(39).
  1426. 037000         05  GRP2-D13AX  REDEFINES  GRP1-D13AX  OCCURS 2 TIMES.
  1427. 037100             07  PLANT-CD-D13AX  PIC X(9)  OCCURS 4 TIMES.
  1428. 037200             07  TYP-GC-HITS-D13AX  PIC XXX.
  1429. 037300         05  FILLER  PIC X(22).
  1430. 037400     03  D14AX  REDEFINES  D11AX.
  1431. 037500         05  SSF-VAL-RAT-D14AX  PIC XX  OCCURS 7 TIMES.
  1432. 037600         05  FILLER  PIC X(86).
  1433. 037700     03  D21AX  REDEFINES  D11AX.
  1434. 037800         05  PLOT-SIZ-D21AX  PIC X.
  1435. 037900         05  PLOT-NUM-D21AX  PIC XX.
  1436. 038000         05  PLANT-CD-D21AX  PIC X(7).
  1437. 038100         05  AGE-CLS-PLANT-D21AX  PIC X.
  1438. 038200         05  FORM-CLS-PLANT-D21AX  PIC X.
  1439. 038300         05  PHNO-STG-D21AX  PIC X.
  1440. 038400         05  CLS-PLANT-AVAIL-D21AX  PIC X.
  1441. 038500         05  CLS-PLANT-UTIL-D21AX  PIC X.
  1442. 038600         05  AVG-HGT-PLANT-D21AX.
  1443. 038700             07  AVG-HGT-PLANT-INGR-D21AX  PIC XXX.
  1444. 038800             07  AVG-HGT-PLANT-FRC-D21AX  PIC XX.
  1445. 038900         05  CHARZD-NUM-D21AX  PIC XXX.
  1446. 039000         05  AVG-LDR-LGT-D21AX.
  1447. 039100             07  AVG-LDR-LGT-INGR-D21AX  PIC XXX.
  1448. 039200             07  AVG-LDR-LGT-FRC-D21AX  PIC XX.
  1449. 039300         05  AVG-CRN-DIA-D21AX.
  1450. 039400             07  AVG-CRN-DIA-INGR-D21AX  PIC XXX.
  1451. 039500             07  AVG-CRN-DIA-FRC-D21AX  PIC XX.
  1452. 039600         05  CHARZD-NOT-NUM-D21AX  PIC XXX.
  1453. 039700         05  MAST-CROPS-CD-D21AX  PIC X.
  1454. 039800         05  FILLER  PIC X(63).
  1455. 039900     03  V3XAX  REDEFINES  D11AX.
  1456. 040000         05  PLOT-TOT-NUM-V3XAX  PIC XX.
  1457. 040100         05  PLOT-SIZ-EST-V3XAX.
  1458. 040200             07  PLOT-SIZ-EST-INGR-V3XAX  PIC X(5).
  1459. 040300             07  PLOT-SIZ-EST-FRC-V3XAX  PIC XX.
  1460. 040400         05  PLANT-CD-V3XAX  PIC X(7).
  1461. 040500         05  HGT-CLS-CD-V3XAX  PIC X.
  1462. 040600         05  HRBG-PROD-WGT-V3XAX  PIC XXXX  OCCURS 10 TIMES.
  1463. 040700         05  FILLER  PIC X(43).
  1464. 040800     03  V3XBX  REDEFINES  D11AX.
  1465. 040900         05  PLOT-TOT-NUM-V3XBX  PIC XX.
  1466. 041000         05  PLOT-SIZ-EST-V3XBX.
  1467. 041100             07  PLOT-SIZ-EST-INGR-V3XBX  PIC X(5).
  1468. 041200             07  PLOT-SIZ-EST-FRC-V3XBX  PIC XX.
  1469. 041300         05  PLANT-CD-V3XBX  PIC X(7).
  1470. 041400         05  HGT-CLS-CD-V3XBX  PIC X.
  1471. 041500         05  GRP-V3XBX  OCCURS 10 TIMES.
  1472. 041600             07  CLS-PLANT-AVAIL-V3XBX  PIC X.
  1473. 041700             07  PHNO-STG-V3XBX  PIC X.
  1474. 041800             07  CLS-PLANT-UTIL-V3XBX  PIC X.
  1475. 041900             07  HRBG-PROD-WGT-V3XBX  PIC XXXX.
  1476. 042000         05  FILLER  PIC X(13).
  1477. 042100 01 DIC-HOLD.
  1478. 042200     03  INV-HLD.
  1479. 042300         05  INV-NM    PIC       X(20).
  1480. 042400         05  ST-DIST-CD.
  1481. 042500             07  ST-CD-HLD       PIC       X(02).
  1482. 042600             07  DI-CD-HLD       PIC       X(02).
  1483. 042700     03  EXPL-HLD.
  1484. 042800         05  DIST-NM-HLD         PIC       X(12).
  1485. 042900     03  FUNC-HLD.
  1486. 043000         05  ST-NM-HLD           PIC       X(10).
  1487. 043100         05  FILLER              PIC       X(14).
  1488. 043200     COPY DBSTATUS IN TPCOBOLIB.
  1489. 043300 01  INVENTORY    PIC XXXX  VALUE SPACE.
  1490. 043400 PROCEDURE DIVISION.
  1491. 043500 START-PARA.
  1492. 043600     ACCEPT DAT-H FROM DATE.  MOVE MON-T (MON-H) TO MON-PH1.
  1493. 043700     MOVE DAY-H TO DAY-PH1.  MOVE YER-H TO YER-PH1.
  1494. 043800     OPEN INPUT  FIL-I1,
  1495. 043900          OUTPUT FIL-P1.
  1496. 044000     ACCEPT INVENTORY.
  1497. 044100     READY DIC-DE.
  1498. 044200 000-VALIDATE-INV.
  1499. 044300     MOVE INVENTORY TO DE-CD-8822-DEC  INVEN-CD-HDR.
  1500. 044400     MOVE 3940 TO DE-NO-8801-DEC.
  1501. 044500     FIND ANY CODE-DEC.
  1502. 044600     MOVE DB-STATUS TO DB-STAT.
  1503. 044700     IF  NOT OK
  1504. 044800         MOVE "UNKNOWN" TO STATE-HDR   INVENTORY-HDR
  1505. 044900         GO  TO 000-EXIT.
  1506. 045000     GET CODE-DEC.
  1507. 045100     MOVE DB-STATUS TO DB-STAT.
  1508. 045200     IF  NOT OK
  1509. 045300         MOVE "UNKNOWN" TO STATE-HDR   INVENTORY-HDR
  1510. 045400         GO  TO 000-EXIT.
  1511. 045500     MOVE DE-CD-NAM-8823-DEC TO INV-HLD.
  1512. 045600     MOVE INV-NM TO INVENTORY-HDR.
  1513. 045700 000-VALIDATE-STDI.
  1514. 045800     MOVE ST-DIST-CD TO DE-CD-8822-DEC.
  1515. 045900     MOVE 0003 TO DE-NO-8801-DEC.
  1516. 046000     FIND ANY CODE-DEC.
  1517. 046100     MOVE DB-STATUS TO DB-STAT.
  1518. 046200     IF  NOT OK
  1519. 046300         MOVE "UNKNOWN" TO STATE-HDR
  1520. 046400         GO  TO 000-EXIT.
  1521. 046500     GET CODE-DEC.
  1522. 046600     MOVE DB-STATUS TO DB-STAT.
  1523. 046700     IF  NOT OK
  1524. 046800         MOVE "UNKNOWN" TO STATE-HDR
  1525. 046900         GO  TO 000-EXIT.
  1526. 047000     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  1527. 047100     MOVE DB-STATUS TO DB-STAT.
  1528. 047200     IF  NOT OK
  1529. 047300         MOVE "UNKNOWN" TO STATE-HDR
  1530. 047400         GO  TO 000-EXIT.
  1531. 047500     GET CODE-EXPL-DECE.
  1532. 047600     MOVE DB-STATUS TO DB-STAT.
  1533. 047700     IF  NOT OK
  1534. 047800         MOVE "UNKNOWN" TO STATE-HDR
  1535. 047900         GO  TO 000-EXIT.
  1536. 048000     MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD.
  1537. 048100     MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
  1538. 048200     MOVE ST-NM-HLD TO STATE-HDR.
  1539. 048300 000-EXIT.
  1540. 048400     EXIT.
  1541. 048500 000-FINISH.
  1542. 048600     FINISH DIC-DE.
  1543. 048700 0400.
  1544. 048800     READ FIL-I1  AT END
  1545. 048900         DISPLAY "RECORDS IN = ", IN-CNTR
  1546. 049000         CLOSE FIL-I1, FIL-P1  STOP RUN.
  1547. 049100     MOVE REC-I1 TO D11X.  ADD 1 TO IN-CNTR.
  1548. 049200     IF ADST-CD-T-TRN-NUM-D11H NOT = ADST-CD-T-TRN-NUM-D11X
  1549. 049300         MOVE ADST-CD-T-TRN-NUM-D11X TO ADST-CD-T-TRN-NUM-D11H
  1550. 049400         MOVE 1 TO RITE-HDR-FLG, RITE-KEY-FLG  MOVE 52 TO LIN-CHK
  1551. 049500         MOVE ADST-CD-D11H TO ADST-CD-KL1A
  1552. 049600         MOVE DIST-CD-D11H TO DIST-CD-KL1A
  1553. 049700         MOVE PLU-CD-D11H TO PLU-CD-KL1A
  1554. 049800         MOVE ALLOT-NUM-D11H TO ALLOT-NUM-KL1A
  1555. 049900         MOVE SWA-CD-D11H TO SWA-CD-KL1A
  1556. 050000         MOVE TRN-NUM-D11H TO TRN-NUM-KL1A.
  1557. 050100     IF REC-TYP-D11X = "V2"  GO TO 0900.
  1558. 050200     IF REC-TYP-D11X = "V3"  MOVE 1 TO SS2A  GO TO 1000.
  1559. 050300     IF REC-TYP-D11X NOT = "V1"
  1560. 050400         DISPLAY REC-TYP-T-FMT-CD-D11X
  1561. 050500         DISPLAY "BAD RECORD TYPE"  CALL "ABOR".
  1562. 050600     IF FMT-NUM-D11X = "2"  MOVE 1 TO SS1A  GO TO 0600.
  1563. 050700     IF FMT-NUM-D11X = "3"  MOVE 1 TO SS1A, SS1B  GO TO 0700.
  1564. 050800     IF FMT-NUM-D11X = "4"  MOVE 1 TO SS1A  GO TO 0800.
  1565. 050900     IF FMT-NUM-D11X NOT = "1"
  1566. 051000         DISPLAY "BAD FORMAT NUMBER"  CALL "ABOR".
  1567. 051100     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
  1568. 051200         MOVE COL-HDRA11 TO COL-HDR2A1
  1569. 051300         MOVE COL-HDRB11 TO COL-HDR2B1
  1570. 051400         MOVE COL-HDRC11 TO COL-HDR2C1
  1571. 051500         MOVE 1 TO RITE-HDR-FLG.
  1572. 051600     IF SWA-BRWD-D11X NOT = SPACES
  1573. 051700         MOVE SWA-BRWD-D11X TO SWA-BRWD-DL1A11  GO TO 1300.
  1574. 051800     MOVE RNG-SITE-ID-D11AX TO RNG-SITE-ID-DL1A11.
  1575. 051900     MOVE RNG-ECOL-COND-CLS-D11AX TO RNG-ECOL-COND-CLS-DL1A11.
  1576. 052000     MOVE VEG-SUB-TYP-D11AX TO VEG-SUB-TYP-DL1A11.
  1577. 052100     MOVE SWA-PCT-D11AX TO SWA-PCT-DL1A11.
  1578. 052200     MOVE DATA-DAT-D11AX TO DATA-DAT-DL1A11.
  1579. 052300     MOVE RECER-INTLS-D11AX TO RECER-INTLS-DL1A11.
  1580. 052400     MOVE PHOTO-ID-D11AX TO PHOTO-ID-DL1A11.
  1581. 052500     MOVE ADST-CD-CMPR-D11AX TO ADST-CD-CMPR-DL1A11.
  1582. 052600     MOVE DIST-CD-CMPR-D11AX TO DIST-CD-CMPR-DL1A11.
  1583. 052700     MOVE TWP-CMPR-D11AX TO TWP-CMPR-DL1A11.
  1584. 052800     MOVE RNG-CMPR-D11AX TO RNG-CMPR-DL1A11.
  1585. 052900     MOVE CONS-NUM-CMPR-D11AX TO CONS-NUM-CMPR-DL1A11.
  1586. 053000     GO TO 1300.
  1587. 053100 0600.
  1588. 053200     MOVE PLANT-CD-D12AX (SS1A) TO PLANT-CD-DL1A12 (SS1A).
  1589. 053300     IF SS1A < 4  ADD 1 TO SS1A  GO TO 0600.
  1590. 053400     MOVE TYP-GC-CD-D12AX TO TYP-GC-CD-DL1A12.
  1591. 053500     MOVE TYP-GC-HITS-D12AX TO TYP-GC-HITS-DL1A12.
  1592. 053600     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
  1593. 053700         MOVE COL-HDRA12 TO COL-HDR2A1
  1594. 053800         MOVE COL-HDRB12 TO COL-HDR2B1
  1595. 053900         MOVE COL-HDRC12 TO COL-HDR2C1
  1596. 054000         MOVE 1 TO RITE-HDR-FLG.  GO TO 1300.
  1597. 054100 0700.
  1598. 054200     MOVE PLANT-CD-D13AX (SS1A, SS1B)
  1599. 054300          TO PLANT-CD-DL1A13 (SS1A, SS1B).
  1600. 054400     IF SS1B < 4  ADD 1 TO SS1B  GO TO 0700.
  1601. 054500     MOVE TYP-GC-HITS-D13AX (SS1A) TO TYP-GC-HITS-DL1A13 (SS1A).
  1602. 054600     IF SS1A < 2 AND PLANT-CDS-TYP-GC-HITS-D13AX NOT = SPACES
  1603. 054700         MOVE 2 TO SS1A  MOVE 1 TO SS1B  GO TO 0700.
  1604. 054800     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
  1605. 054900         MOVE COL-HDRA13 TO COL-HDR2A1
  1606. 055000         MOVE COL-HDRB13 TO COL-HDR2B1
  1607. 055100         MOVE COL-HDRC13 TO COL-HDR2C1
  1608. 055200         MOVE 1 TO RITE-HDR-FLG.  GO TO 1300.
  1609. 055300 0800.
  1610. 055400     MOVE SSF-VAL-RAT-D14AX (SS1A) TO SSF-VAL-RAT-DL1A14 (SS1A).
  1611. 055500     IF SS1A < 7  ADD 1 TO SS1A  GO TO 0800.
  1612. 055600     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
  1613. 055700         MOVE COL-HDRA14 TO COL-HDR2A1
  1614. 055800         MOVE COL-HDRB14 TO COL-HDR2B1
  1615. 055900         MOVE COL-HDRC14 TO COL-HDR2C1
  1616. 056000         MOVE 1 TO RITE-HDR-FLG.  GO TO 1300.
  1617. 056100 0900.
  1618. 056200     MOVE PLOT-SIZ-D21AX TO PLOT-SIZ-DL1A21.
  1619. 056300     MOVE PLOT-NUM-D21AX TO PLOT-NUM-DL1A21.
  1620. 056400     MOVE PLANT-CD-D21AX TO PLANT-CD-DL1A21.
  1621. 056500     MOVE AGE-CLS-PLANT-D21AX TO AGE-CLS-PLANT-DL1A21.
  1622. 056600     MOVE FORM-CLS-PLANT-D21AX TO FORM-CLS-PLANT-DL1A21.
  1623. 056700     MOVE PHNO-STG-D21AX TO PHNO-STG-DL1A21.
  1624. 056800     MOVE CLS-PLANT-AVAIL-D21AX TO CLS-PLANT-AVAIL-DL1A21.
  1625. 056900     MOVE CLS-PLANT-UTIL-D21AX TO CLS-PLANT-UTIL-DL1A21.
  1626. 057000     IF AVG-HGT-PLANT-D21AX NOT = SPACES
  1627. 057100         MOVE AVG-HGT-PLANT-INGR-D21AX
  1628. 057200             TO AVG-HGT-PLANT-INGR-DL1A21
  1629. 057300         MOVE "." TO AVG-HGT-PLANT-DEC-DL1A21
  1630. 057400         MOVE AVG-HGT-PLANT-FRC-D21AX TO AVG-HGT-PLANT-FRC-DL1A21.
  1631. 057500     MOVE CHARZD-NUM-D21AX TO CHARZD-NUM-DL1A21.
  1632. 057600     IF AVG-LDR-LGT-D21AX NOT = SPACES
  1633. 057700         MOVE AVG-LDR-LGT-INGR-D21AX TO AVG-LDR-LGT-INGR-DL1A21
  1634. 057800         MOVE "." TO AVG-LDR-LGT-DEC-DL1A21
  1635. 057900         MOVE AVG-LDR-LGT-FRC-D21AX TO AVG-LDR-LGT-FRC-DL1A21.
  1636. 058000     IF AVG-CRN-DIA-D21AX NOT = SPACES
  1637. 058100         MOVE AVG-CRN-DIA-INGR-D21AX TO AVG-CRN-DIA-INGR-DL1A21
  1638. 058200         MOVE "." TO AVG-CRN-DIA-DEC-DL1A21
  1639. 058300         MOVE AVG-CRN-DIA-FRC-D21AX TO AVG-CRN-DIA-FRC-DL1A21.
  1640. 058400     MOVE CHARZD-NOT-NUM-D21AX TO CHARZD-NOT-NUM-DL1A21.
  1641. 058500     MOVE MAST-CROPS-CD-D21AX TO MAST-CROPS-CD-DL1A21.
  1642. 058600     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
  1643. 058700         MOVE COL-HDRA21 TO COL-HDR2A1
  1644. 058800         MOVE COL-HDRB21 TO COL-HDR2B1
  1645. 058900         MOVE COL-HDRC21 TO COL-HDR2C1
  1646. 059000         MOVE 1 TO RITE-HDR-FLG.  GO TO 1300.
  1647. 059100 1000.
  1648. 059200     IF FMT-CD-D11X = "B"  GO TO 1200.
  1649. 059300     IF FMT-CD-D11X NOT = "A"
  1650. 059400         DISPLAY "BAD FORMAT CODE"  CALL "ABOR".
  1651. 059500     MOVE PLOT-TOT-NUM-V3XAX TO PLOT-TOT-NUM-DL1A3A.
  1652. 059600     IF PLOT-SIZ-EST-V3XAX NOT = SPACES
  1653. 059700         MOVE PLOT-SIZ-EST-INGR-V3XAX TO PLOT-SIZ-EST-INGR-DL1A3A
  1654. 059800         MOVE "." TO PLOT-SIZ-EST-DEC-DL1A3A
  1655. 059900         MOVE PLOT-SIZ-EST-FRC-V3XAX TO PLOT-SIZ-EST-FRC-DL1A3A.
  1656. 060000     MOVE PLANT-CD-V3XAX TO PLANT-CD-DL1A3A.
  1657. 060100     MOVE HGT-CLS-CD-V3XAX TO HGT-CLS-CD-DL1A3A.
  1658. 060200 1100.
  1659. 060300     MOVE HRBG-PROD-WGT-V3XAX (SS2A)
  1660. 060400         TO HRBG-PROD-WGT-DL1A3A (SS2A).
  1661. 060500     IF SS2A < 10  ADD 1 TO SS2A  GO TO 1100.
  1662. 060600     MOVE FMT-NUM-D11X TO FMT-NUM-DL1A.
  1663. 060700     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
  1664. 060800         MOVE COL-HDRA3A TO COL-HDR2A1
  1665. 060900         MOVE COL-HDRB3A TO COL-HDR2B1
  1666. 061000         MOVE COL-HDRC3A TO COL-HDR2C1
  1667. 061100         MOVE 1 TO RITE-HDR-FLG.  GO TO 1300.
  1668. 061200 1200.
  1669. 061300     MOVE GRP-V3XBX (SS2A) TO GRP2-DL1A3B (SS2A).
  1670. 061400     IF SS2A < 10  ADD 1 TO SS2A  GO TO 1200.
  1671. 061500     MOVE PLOT-TOT-NUM-V3XBX TO PLOT-TOT-NUM-DL1A3B.
  1672. 061600     IF PLOT-SIZ-EST-V3XBX NOT = SPACES
  1673. 061700         MOVE PLOT-SIZ-EST-INGR-V3XBX TO PLOT-SIZ-EST-INGR-DL1A3B
  1674. 061800         MOVE "." TO PLOT-SIZ-EST-DEC-DL1A3B
  1675. 061900         MOVE PLOT-SIZ-EST-FRC-V3XBX TO PLOT-SIZ-EST-FRC-DL1A3B.
  1676. 062000     MOVE PLANT-CD-V3XBX TO PLANT-CD-DL1A3B.
  1677. 062100     MOVE HGT-CLS-CD-V3XBX TO HGT-CLS-CD-DL1A3B.
  1678. 062200     MOVE FMT-NUM-D11X TO FMT-NUM-DL1A.
  1679. 062300     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-D11X
  1680. 062400         MOVE COL-HDRA3B TO COL-HDR2A1
  1681. 062500         MOVE COL-HDRB3B TO COL-HDR2B1
  1682. 062600         MOVE COL-HDRC3B TO COL-HDR2C1
  1683. 062700         MOVE 1 TO RITE-HDR-FLG.
  1684. 062800 1300.
  1685. 062900     MOVE REC-TYP-T-FMT-CD-D11X
  1686. 063000         TO REC-TYP-T-FMT-CD-DL1A.
  1687. 063100     MOVE ACTN-CD-D11X TO ACTN-CD-DL1A.
  1688. 063200     MOVE LIN-NUM-D11X TO LIN-NUM-DL1A.
  1689. 063300 1400.
  1690. 063400     MOVE ZERO TO LIN-CNTR.
  1691. 063500     IF RITE-HDR-FLG NOT ZERO  ADD 4 TO LIN-CNTR.
  1692. 063600     IF RITE-KEY-FLG NOT ZERO  ADD 6 TO LIN-CNTR.
  1693. 063700     ADD 2 TO LIN-CNTR.  ADD LIN-CNTR TO LIN-CHK.
  1694. 063800     IF LIN-CHK > 52  ADD 1 TO PAG-CNTR
  1695. 063900         MOVE PAG-CNTR TO PAG-CNT-PH1  MOVE ZERO TO LIN-CHK
  1696. 064000         MOVE 1 TO RITE-HDR-FLG, RITE-KEY-FLG
  1697. 064100         MOVE PAG-HDR1 TO REC-P1
  1698. 064200         WRITE REC-P1 AFTER ADVANCING PAGE
  1699. 064300         MOVE PAG-HDR2 TO REC-P1
  1700. 064400         WRITE REC-P1 AFTER ADVANCING 2 LINES
  1701. 064500         MOVE SPACES TO REC-P1  WRITE REC-P1  GO TO 1400.
  1702. 064600     IF RITE-KEY-FLG ZERO  GO TO 1500.
  1703. 064700     MOVE ZERO TO RITE-KEY-FLG.
  1704. 064800     MOVE COL-HDR1A TO REC-P1.
  1705. 064900     WRITE REC-P1 AFTER ADVANCING 2 LINES.
  1706. 065000     MOVE COL-HDR1B TO REC-P1.  WRITE REC-P1.
  1707. 065100     MOVE COL-HDR1C TO REC-P1.  WRITE REC-P1.
  1708. 065200     MOVE KEY-LIN1A TO REC-P1.
  1709. 065300     WRITE REC-P1 AFTER ADVANCING 2 LINES.
  1710. 065400 1500.
  1711. 065500     IF RITE-HDR-FLG NOT ZERO
  1712. 065600         MOVE ZERO TO RITE-HDR-FLG
  1713. 065700         MOVE COL-HDR2A TO REC-P1
  1714. 065800         WRITE REC-P1 AFTER ADVANCING 2 LINES
  1715. 065900         MOVE COL-HDR2B TO REC-P1  WRITE REC-P1
  1716. 066000         MOVE COL-HDR2C TO REC-P1  WRITE REC-P1.
  1717. 066100     MOVE DATA-LIN1A TO REC-P1.
  1718. 066200     WRITE REC-P1 AFTER ADVANCING 2 LINES.
  1719. 066300     MOVE SPACES TO DATA-LIN1A11.  GO TO 0400.
  1720. 000000*-----------------------------------------------------------------
  1721. 000100 IDENTIFICATION DIVISION.
  1722. 000200 PROGRAM-ID. ES030E.
  1723. 000300*        VEGETATIVE EDIT AND ERROR LIST
  1724. 000400*
  1725. 000500 AUTHOR. CHUCK SLIZEWSKI.
  1726. 000600 DATE-WRITTEN.   01/10/79.
  1727. 000700 DATE-COMPILED.
  1728. 000800 ENVIRONMENT DIVISION.
  1729. 000900 CONFIGURATION SECTION.
  1730. 001000 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  1731. 001100 OBJECT-COMPUTER.  LEVEL-66-ASCII.
  1732. 001200 INPUT-OUTPUT SECTION.
  1733. 001300 FILE-CONTROL.
  1734. 001400     SELECT FIL-I1    ASSIGN TO I1
  1735. 001500         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  1736. 001600     SELECT FIL-D1    ASSIGN TO D1
  1737. 001700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  1738. 001800     SELECT FIL-P1    ASSIGN TO P1
  1739. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  1740. 002000 DATA DIVISION.
  1741. 002100 SUB-SCHEMA SECTION.
  1742. 002200 DB  CODVAL2 WITHIN BLMDIC.
  1743. 002300 FILE SECTION.
  1744. 002400 FD  FIL-I1
  1745. 002500     CODE-SET IS GBCD
  1746. 002600     LABEL RECORDS ARE STANDARD
  1747. 002700     DATA RECORD IS REC-I1.
  1748. 002800 01  REC-I1.
  1749. 002900     03  FILLER    PIC X(8).
  1750. 003000     03  SDP-I1    PIC X(6).
  1751. 003100     03  FILLER    PIC X(130).
  1752. 003200 FD  FIL-D1
  1753. 003300     CODE-SET IS GBCD
  1754. 003400     LABEL RECORDS ARE STANDARD
  1755. 003500     DATA RECORD IS REC-D1.
  1756. 003600 01  REC-D1  PIC X(144).
  1757. 003700 FD  FIL-P1
  1758. 003800     CODE-SET IS GBCD
  1759. 003900     LABEL RECORDS ARE STANDARD
  1760. 004000     DATA RECORD IS REC-P1.
  1761. 004100 01  REC-P1  PIC X(132).
  1762. 004200 WORKING-STORAGE SECTION.
  1763. 004300 77  CNT-BAD-TYPE            PIC 9(6)  VALUE ZERO.
  1764. 004400 77  CNT-BAD-FORM            PIC 9(6)  VALUE ZERO.
  1765. 004500 77  CNT-BAD-CODE            PIC 9(6)  VALUE ZERO.
  1766. 004600 77  CNT-V1                  PIC 9(6)  VALUE ZERO.
  1767. 004700 77  CNT-V2                  PIC 9(6)  VALUE ZERO.
  1768. 004800 77  CNT-V3                  PIC 9(6)  VALUE ZERO.
  1769. 004900 77  CNT-BAD-PU              PIC 9(6)  VALUE ZERO.
  1770. 005000 77  CNT-BAD-ALOT            PIC 9(6)  VALUE ZERO.
  1771. 005100 77  DATA-FLG  PIC 9  COMP-4  VALUE ZERO.
  1772. 005200 77  PLT-HLD  PIC X(7)  VALUE SPACE.
  1773. 005300 77  PLT-SRC  PIC X(7)  VALUE SPACE.
  1774. 005400 77  FRC-FLG  PIC 9  COMP-4.
  1775. 005500 77  IN-CNTR  PIC 9(6)  COMP-4  VALUE ZERO.
  1776. 005600 77  INGR-FLG  PIC 9  COMP-4.
  1777. 005700 77  KEY-FLG  PIC 9  COMP-4.
  1778. 005800 77  LIN-CHK  PIC 99  COMP-4.
  1779. 005900 77  LIN-CNT  PIC 99  COMP-4.
  1780. 006000 77  LIN-NUM-H  PIC 999.
  1781. 006100 77  OT-CNTR  PIC 9(6)  COMP-4  VALUE ZERO.
  1782. 006200 77  PAG-CNT  PIC 999  COMP-4.
  1783. 006300 77  PLANT-CD-FLG  PIC 9  COMP-4.
  1784. 006400 77  PT-CNTR  PIC 9(6)  COMP-4  VALUE ZERO.
  1785. 006500 77  RITE-HDR-FLG  PIC 9  COMP-4.
  1786. 006600 77  RITE-KEY-FLG  PIC 9  COMP-4.
  1787. 006700 77  SS1A  PIC 9  COMP-4.
  1788. 006800 77  SS1B  PIC 9  COMP-4.
  1789. 006900 77  SS1C  PIC 9  COMP-4.
  1790. 007000 77  SS1D  PIC 9  COMP-4.
  1791. 007100 77  SS2A  PIC 99  COMP-4.
  1792. 007200 77  PLT-SUB          PIC 9(6)  VALUE ZERO.
  1793. 007300 01  PLT-TABLE.
  1794. 007400     03  PLT-TB       PIC X(7)  OCCURS 200 TIMES.
  1795. 007500 01  PLT-TABLE-2.
  1796. 007600     03  PLT-CNT      PIC 999  OCCURS 200 TIMES.
  1797. 007700 01  COL-HDR1A.
  1798. 007800     03  FILLER  PIC X(24)  VALUE "          ST   DIST   PL".
  1799. 007900     03  FILLER  PIC X(24)  VALUE "U   ALLOT   SWA     TRN ".
  1800. 008000     03  FILLER  PIC X(84)  VALUE SPACES.
  1801. 008100 01  COL-HDR1B.
  1802. 008200     03  FILLER  PIC X(24)  VALUE "         9-10  11-12 13-".
  1803. 008300     03  FILLER  PIC X(24)  VALUE "14  15-18   19-22  23-24".
  1804. 008400     03  FILLER  PIC X(84)  VALUE SPACES.
  1805. 008500 01  COL-HDR1C.
  1806. 008600     03  FILLER  PIC X(24)  VALUE "          XX    XX    XX".
  1807. 008700     03  FILLER  PIC X(24)  VALUE "    XXXX    XXXX    XX  ".
  1808. 008800     03  FILLER  PIC X(84)  VALUE SPACES.
  1809. 008900 01  COL-HDRA11  PIC X(108)  VALUE "O SWA/T  RNG SITE    CC  VEG S
  1810. 009000-                        "-TYP  % SWA  DATE    RECR      A/PHOTO
  1811. 009100-                        "CMPR: ST   DIST   TWP   RNG     NUM   ".
  1812. 009200 01  COL-HDRB11  PIC X(108)  VALUE "30-35     45-55      56    57-
  1813. 009300-                        "60    61-63  64-69   70-72      73-88
  1814. 009400-                        "     89-90 91-92 93-97 98-102 103-104 ".
  1815. 009500 01  COL-HDRC11  PIC X(108)  VALUE "XXXXXX  XXXXXXXXXXX  X     XXX
  1816. 009600-                        "X      XXX   XXXXXX   XXX  XXXXXXXXXXXXX
  1817. 009700-                        "XXX   XX    XX   XXXXX XXXXX    XX    ".
  1818. 009800 01  COL-HDRA12  PIC X(108)  VALUE "GRND CVR BASAL  NUM    - - - -
  1819. 009900-                        " -O B S E R V E D   S P E C I E S- - - -
  1820. 010000-                        " -                                    ".
  1821. 010100 01  COL-HDRB12  PIC X(108)  VALUE "   DATA:  45   46-48    49-55
  1822. 010200-                        "        56-62         63-69         70-7
  1823. 010300-                        "6                                     ".
  1824. 010400 01  COL-HDRC12  PIC X(108)  VALUE "          X     XXX    XXXXXXX
  1825. 010500-                        "       XXXXXXX       XXXXXXX       XXXXX
  1826. 010600-                        "XX                                    ".
  1827. 010700 01  COL-HDRA13  PIC X(108)  VALUE "  BASAL    CANOPY 1   CANOPY 2
  1828. 010800-                        "   CANOPY 3   NUM      BASAL    CANOPY 1
  1829. 010900-                        "   CANOPY 2   CANOPY 3   NUM          ".
  1830. 011000 01  COL-HDRB13  PIC X(108)  VALUE "  45-53     54-62      63-71
  1831. 011100-                        "    72-80    81-83     84-92     93-101
  1832. 011200-                        "   102-110    111-119  120-122        ".
  1833. 011300 01  COL-HDRC13  PIC X(108)  VALUE "XXXXXXXXX  XXXXXXXXX  XXXXXXXX
  1834. 011400-                        "X  XXXXXXXXX  XXX    XXXXXXXXX  XXXXXXXX
  1835. 011500-                        "X  XXXXXXXXX  XXXXXXXXX  XXX          ".
  1836. 011600 01  COL-HDRA14  PIC X(108)  VALUE "SOIL MVMT  SOIL LITR  SURF ROC
  1837. 011700-                        "K  PEDESTALL  FLOW PTRN    RILLS     GUL
  1838. 011800-                        "LIES                                  ".
  1839. 011900 01  COL-HDRB14  PIC X(108)  VALUE "  45-46      47-48      49-50
  1840. 012000-                        "     51-52      53-54      55-56      57
  1841. 012100-                        "-58                                   ".
  1842. 012200 01  COL-HDRC14  PIC X(108)  VALUE "   XX         XX         XX
  1843. 012300-                        "      XX         XX         XX         X
  1844. 012400-                        "X                                     ".
  1845. 012500 01  COL-HDRA21  PIC X(108)  VALUE "SIZ/PLOT/NUM   SPECIES  AGE/CL
  1846. 012600-                        "ASS/FORM  PHNO  AVAIL  UTIL  HGT   D/CNT
  1847. 012700-                        "  L/LGT  CROWN DIA  N/CHARZD  M/CROPS ".
  1848. 012800 01  COL-HDRB21  PIC X(108)  VALUE "45      46-47   48-54   55
  1849. 012900-                        "     56    57    58     59  60-64  65-67
  1850. 013000-                        "  68-72    73-77     78-80      81    ".
  1851. 013100 01  COL-HDRC21  PIC X(108)  VALUE " X       XX    XXXXXXX   X
  1852. 013200-                        "     X     X      X     X   XXX XX  XXX
  1853. 013300-                        "  XXX XX   XXX XX     XXX        X    ".
  1854. 013400 01  COL-HDRA3B  PIC X(108)  VALUE "NUM/PLOT/SIZ SPECIES HGT WE
  1855. 013500-                        " 1       2       3       4       5
  1856. 013600-                        " 6       7       8       9      10    ".
  1857. 013700 01  COL-HDRB3B  PIC X(108)  VALUE "45-46 47-53   54-60  61  D:  6
  1858. 013800-                        "2-68   69-75   76-82   83-89   90-96  97
  1859. 013900-                        "-103  104-110 111-117 118-124 125-131 ".
  1860. 014000 01  COL-HDRC3B  PIC X(108)  VALUE " XX XXXXX XX XXXXXXX  X     XX
  1861. 014100-                        "XXXXX XXXXXXX XXXXXXX XXXXXXX XXXXXXX XX
  1862. 014200-                        "XXXXX XXXXXXX XXXXXXX XXXXXXX XXXXXXX ".
  1863. 014300 01  COL-HDR2A.
  1864. 014400     03  FILLER  PIC X(24)  VALUE "REC TYP  ACTN  LIN NUM  ".
  1865. 014500     03  COL-HDR2A1  PIC X(108).
  1866. 014600 01  COL-HDR2B.
  1867. 014700     03  FILLER  PIC X(24)  VALUE " 5-8      25    26-28   ".
  1868. 014800     03  COL-HDR2B1  PIC X(108).
  1869. 014900 01  COL-HDR2C.
  1870. 015000     03  FILLER  PIC X(24)  VALUE " XXXX     X      XXX    ".
  1871. 015100     03  COL-HDR2C1  PIC X(108).
  1872. 015200 01  DATA-LIN1A  VALUE SPACES.
  1873. 015300     03  FILLER  PIC X.
  1874. 015400     03  REC-TYP-T-FMT-CD-DL1A.
  1875. 015500         05  FILLER  PIC XX.
  1876. 015600         05  FMT-NUM-DL1A  PIC X.
  1877. 015700         05  FILLER  PIC X.
  1878. 015800     03  FILLER  PIC X(5).
  1879. 015900     03  ACTN-CD-DL1A  PIC X.
  1880. 016000     03  FILLER  PIC X(6).
  1881. 016100     03  LIN-NUM-DL1A  PIC XXX.
  1882. 016200     03  FILLER  PIC XXXX.
  1883. 016300     03  DATA-LIN1A11.
  1884. 016400         05  SWA-BRWD-DL1A11  PIC X(6).
  1885. 016500         05  FILLER  PIC XX.
  1886. 016600         05  RNG-SITE-ID-DL1A11  PIC X(11).
  1887. 016700         05  FILLER  PIC XX.
  1888. 016800         05  RNG-ECOL-COND-CLS-DL1A11  PIC X.
  1889. 016900         05  FILLER  PIC X(5).
  1890. 017000         05  VEG-SUB-TYP-DL1A11  PIC XXXX.
  1891. 017100         05  FILLER  PIC X(6).
  1892. 017200         05  SWA-PCT-DL1A11  PIC XXX.
  1893. 017300         05  FILLER  PIC XXX.
  1894. 017400         05  DATA-DAT-DL1A11  PIC X(6).
  1895. 017500         05  FILLER  PIC XXX.
  1896. 017600         05  RECER-INTLS-DL1A11  PIC XXX.
  1897. 017700         05  FILLER  PIC XX.
  1898. 017800         05  PHOTO-ID-DL1A11  PIC X(16).
  1899. 017900         05  FILLER  PIC XXX.
  1900. 018000         05  ADST-CD-CMPR-DL1A11  PIC XX.
  1901. 018100         05  FILLER  PIC XXXX.
  1902. 018200         05  DIST-CD-CMPR-DL1A11  PIC XX.
  1903. 018300         05  FILLER  PIC XXX.
  1904. 018400         05  TWP-CMPR-DL1A11  PIC X(5).
  1905. 018500         05  FILLER  PIC X.
  1906. 018600         05  RNG-CMPR-DL1A11  PIC X(5).
  1907. 018700         05  FILLER  PIC XXXX.
  1908. 018800         05  CONS-NUM-CMPR-DL1A11  PIC XX.
  1909. 018900         05  FILLER  PIC XXXX.
  1910. 019000     03  DATA-LIN1A12  REDEFINES  DATA-LIN1A11.
  1911. 019100         05  FILLER  PIC X(10).
  1912. 019200         05  TYP-GC-CD-DL1A12  PIC X.
  1913. 019300         05  FILLER  PIC X(5).
  1914. 019400         05  TYP-GC-HITS-DL1A12  PIC XXX.
  1915. 019500         05  FILLER  PIC XXXX.
  1916. 019600         05  GRP-DL1A12  OCCURS 4 TIMES.
  1917. 019700             07  PLANT-CD-DL1A12  PIC X(7).
  1918. 019800             07  FILLER  PIC X(7).
  1919. 019900         05  FILLER  PIC X(29).
  1920. 020000     03  DATA-LIN1A13  REDEFINES  DATA-LIN1A11.
  1921. 020100         05  GRP1-DL1A13  OCCURS 2 TIMES.
  1922. 020200             07  GRP2-DL1A13  OCCURS 4 TIMES.
  1923. 020300                 09  PLANT-CD-DL1A13  PIC X(9).
  1924. 020400                 09  FILLER  PIC XX.
  1925. 020500             07  TYP-GC-HITS-DL1A13  PIC XXX.
  1926. 020600             07  FILLER  PIC XXXX.
  1927. 020700         05  FILLER  PIC X(6).
  1928. 020800     03  DATA-LIN1A14  REDEFINES  DATA-LIN1A11.
  1929. 020900         05  FILLER  PIC XXX.
  1930. 021000         05  GRP-DL1A14  OCCURS 7 TIMES.
  1931. 021100             07  SSF-VAL-RAT-DL1A14  PIC XX.
  1932. 021200             07  FILLER  PIC X(9).
  1933. 021300         05  FILLER  PIC X(28).
  1934. 021400     03  DATA-LIN1A21  REDEFINES  DATA-LIN1A11.
  1935. 021500         05  FILLER  PIC X.
  1936. 021600         05  PLOT-SIZ-DL1A21  PIC X.
  1937. 021700         05  FILLER  PIC X(7).
  1938. 021800         05  PLOT-NUM-DL1A21  PIC XX.
  1939. 021900         05  FILLER  PIC XXXX.
  1940. 022000         05  PLANT-CD-DL1A21  PIC X(7).
  1941. 022100         05  FILLER  PIC XXX.
  1942. 022200         05  AGE-CLS-PLANT-DL1A21  PIC X.
  1943. 022300         05  FILLER  PIC X(9).
  1944. 022400         05  FORM-CLS-PLANT-DL1A21  PIC X.
  1945. 022500         05  FILLER  PIC X(5).
  1946. 022600         05  PHNO-STG-DL1A21  PIC X.
  1947. 022700         05  FILLER  PIC X(6).
  1948. 022800         05  CLS-PLANT-AVAIL-DL1A21  PIC X.
  1949. 022900         05  FILLER  PIC X(5).
  1950. 023000         05  CLS-PLANT-UTIL-DL1A21  PIC X.
  1951. 023100         05  FILLER  PIC XXX.
  1952. 023200         05  AVG-HGT-PLANT-INGR-DL1A21  PIC XXX.
  1953. 023300         05  AVG-HGT-PLANT-DEC-DL1A21  PIC X.
  1954. 023400         05  AVG-HGT-PLANT-FRC-DL1A21  PIC XX.
  1955. 023500         05  FILLER  PIC XX.
  1956. 023600         05  CHARZD-NUM-DL1A21  PIC XXX.
  1957. 023700         05  FILLER  PIC XXX.
  1958. 023800         05  AVG-LDR-LGT-INGR-DL1A21  PIC XXX.
  1959. 023900         05  AVG-LDR-LGT-DEC-DL1A21  PIC X.
  1960. 024000         05  AVG-LDR-LGT-FRC-DL1A21  PIC XX.
  1961. 024100         05  FILLER  PIC XXX.
  1962. 024200         05  AVG-CRN-DIA-INGR-DL1A21  PIC XXX.
  1963. 024300         05  AVG-CRN-DIA-DEC-DL1A21  PIC X.
  1964. 024400         05  AVG-CRN-DIA-FRC-DL1A21  PIC XX.
  1965. 024500         05  FILLER  PIC X(5).
  1966. 024600         05  CHARZD-NOT-NUM-DL1A21  PIC XXX.
  1967. 024700         05  FILLER  PIC X(8).
  1968. 024800         05  MAST-CROPS-CD-DL1A21  PIC X.
  1969. 024900         05  FILLER  PIC XXXX.
  1970. 025000     03  DATA-LIN1A3B  REDEFINES  DATA-LIN1A11.
  1971. 025100         05  FILLER  PIC X.
  1972. 025200         05  PLOT-TOT-NUM-DL1A3B  PIC XX.
  1973. 025300         05  FILLER  PIC X.
  1974. 025400         05  PLOT-SIZ-EST-INGR-DL1A3B  PIC X(5).
  1975. 025500         05  PLOT-SIZ-EST-DEC-DL1A3B  PIC X.
  1976. 025600         05  PLOT-SIZ-EST-FRC-DL1A3B  PIC XX.
  1977. 025700         05  FILLER  PIC X.
  1978. 025800         05  PLANT-CD-DL1A3B  PIC X(7).
  1979. 025900         05  FILLER  PIC XX.
  1980. 026000         05  HGT-CLS-CD-DL1A3B  PIC X.
  1981. 026100         05  FILLER  PIC X(5).
  1982. 026200         05  GRP1-DL1A3B  OCCURS 10 TIMES.
  1983. 026300             07  GRP2-DL1A3B  PIC X(7).
  1984. 026400             07  FILLER  PIC X.
  1985. 026500 01  DATA-LIN1B  VALUE SPACES.
  1986. 026600     03  FILLER  PIC X(17).
  1987. 026700     03  DATA-LIN1B11.
  1988. 026800         05  LIN-NUM-DL1B  PIC XXX.
  1989. 026900         05  FILLER  PIC XXXX.
  1990. 027000         05  SWA-CD-BRWD-DL1B11  PIC X.
  1991. 027100         05  SWA-NUM-BRWD-DL1B11  PIC XXX.
  1992. 027200         05  TRN-NUM-BRWD-DL1B11  PIC XX.
  1993. 027300         05  FILLER  PIC XX.
  1994. 027400         05  RNG-SITE-ID-DL1B11  PIC X(11).
  1995. 027500         05  FILLER  PIC XX.
  1996. 027600         05  RNG-ECOL-COND-CLS-DL1B11  PIC X.
  1997. 027700         05  FILLER  PIC X(5).
  1998. 027800         05  VEG-SUB-TYP-DL1B11  PIC XXXX.
  1999. 027900         05  FILLER  PIC X(6).
  2000. 028000         05  SWA-PCT-DL1B11  PIC XXX.
  2001. 028100         05  FILLER  PIC XXX.
  2002. 028200         05  DATA-DAT-DL1B11.
  2003. 028300             07  DATA-YER-DL1B11  PIC XX.
  2004. 028400             07  DATA-MON-DL1B11  PIC XX.
  2005. 028500             07  DATA-DAY-DL1B11  PIC XX.
  2006. 028600         05  FILLER  PIC XXX.
  2007. 028700         05  RECER-INTLS-DL1B11  PIC XXX.
  2008. 028800         05  FILLER  PIC XX.
  2009. 028900         05  PHOTO-ID-DL1B11  PIC X(16).
  2010. 029000         05  FILLER  PIC XXX.
  2011. 029100         05  ADST-CD-CMPR-DL1B11  PIC XX.
  2012. 029200         05  FILLER  PIC XXXX.
  2013. 029300         05  DIST-CD-CMPR-DL1B11  PIC XX.
  2014. 029400         05  FILLER  PIC XXX.
  2015. 029500         05  TWP-CMPR-DL1B11  PIC X(5).
  2016. 029600         05  FILLER  PIC X.
  2017. 029700         05  RNG-CMPR-DL1B11  PIC X(5).
  2018. 029800         05  FILLER  PIC XXXX.
  2019. 029900         05  CONS-NUM-CMPR-DL1B11  PIC XX.
  2020. 030000         05  FILLER  PIC XXXX.
  2021. 030100     03  DATA-LIN1B12  REDEFINES  DATA-LIN1B11.
  2022. 030200         05  FILLER  PIC X(17).
  2023. 030300         05  TYP-GC-CD-DL1B12  PIC X.
  2024. 030400         05  FILLER  PIC X(5).
  2025. 030500         05  TYP-GC-HITS-DL1B12  PIC XXX.
  2026. 030600         05  FILLER  PIC XXXX.
  2027. 030700         05  GRP-DL1B12  OCCURS 4 TIMES.
  2028. 030800             07  PLANT-CD-DL1B12  PIC X(7).
  2029. 030900             07  FILLER  PIC X(7).
  2030. 031000         05  FILLER  PIC X(29).
  2031. 031100     03  DATA-LIN1B13  REDEFINES  DATA-LIN1B11.
  2032. 031200         05  FILLER  PIC X(7).
  2033. 031300         05  GRP1-DL1B13  OCCURS 2 TIMES.
  2034. 031400             07  GRP2-DL1B13  OCCURS 4 TIMES.
  2035. 031500                 09  PLANT-CD-DL1B13  PIC X(9).
  2036. 031600                 09  FILLER  PIC XX.
  2037. 031700             07  TYP-GC-HITS-DL1B13  PIC XXX.
  2038. 031800             07  FILLER  PIC XXXX.
  2039. 031900         05  FILLER  PIC X(6).
  2040. 032000     03  DATA-LIN1B14  REDEFINES  DATA-LIN1B11.
  2041. 032100         05  FILLER  PIC X(10).
  2042. 032200         05  GRP-DL1B14  OCCURS 7 TIMES.
  2043. 032300             07  SSF-VAL-RAT-DL1B14  PIC XX.
  2044. 032400             07  FILLER  PIC X(9).
  2045. 032500         05  FILLER  PIC X(28).
  2046. 032600     03  DATA-LIN1B21  REDEFINES  DATA-LIN1B11.
  2047. 032700         05  FILLER  PIC X(8).
  2048. 032800         05  PLOT-SIZ-DL1B21  PIC X.
  2049. 032900         05  FILLER  PIC X(7).
  2050. 033000         05  PLOT-NUM-DL1B21  PIC XX.
  2051. 033100         05  FILLER  PIC XXXX.
  2052. 033200         05  PLANT-CD-DL1B21  PIC X(7).
  2053. 033300         05  FILLER  PIC XXX.
  2054. 033400         05  AGE-CLS-PLANT-DL1B21  PIC X.
  2055. 033500         05  FILLER  PIC X(9).
  2056. 033600         05  FORM-CLS-PLANT-DL1B21  PIC X.
  2057. 033700         05  FILLER  PIC X(5).
  2058. 033800         05  PHNO-STG-DL1B21  PIC X.
  2059. 033900         05  FILLER  PIC X(6).
  2060. 034000         05  CLS-PLANT-AVAIL-DL1B21  PIC X.
  2061. 034100         05  FILLER  PIC X(5).
  2062. 034200         05  CLS-PLANT-UTIL-DL1B21  PIC X.
  2063. 034300         05  FILLER  PIC XXX.
  2064. 034400         05  AVG-HGT-PLANT-INGR-DL1B21  PIC XXX.
  2065. 034500         05  FILLER  PIC X.
  2066. 034600         05  AVG-HGT-PLANT-FRC-DL1B21  PIC XX.
  2067. 034700         05  FILLER  PIC XX.
  2068. 034800         05  CHARZD-NUM-DL1B21  PIC XXX.
  2069. 034900         05  FILLER  PIC XXX.
  2070. 035000         05  AVG-LDR-LGT-INGR-DL1B21  PIC XXX.
  2071. 035100         05  FILLER  PIC X.
  2072. 035200         05  AVG-LDR-LGT-FRC-DL1B21  PIC XX.
  2073. 035300         05  FILLER  PIC XXX.
  2074. 035400         05  AVG-CRN-DIA-INGR-DL1B21  PIC XXX.
  2075. 035500         05  FILLER  PIC X.
  2076. 035600         05  AVG-CRN-DIA-FRC-DL1B21  PIC XX.
  2077. 035700         05  FILLER  PIC X(5).
  2078. 035800         05  CHARZD-NOT-NUM-DL1B21  PIC XXX.
  2079. 035900         05  FILLER  PIC X(8).
  2080. 036000         05  MAST-CROPS-CD-DL1B21  PIC X.
  2081. 036100         05  FILLER  PIC XXXX.
  2082. 036200     03  DATA-LIN1B3B  REDEFINES  DATA-LIN1B11.
  2083. 036300         05  FILLER  PIC X(8).
  2084. 036400         05  PLOT-TOT-NUM-DL1B3B  PIC XX.
  2085. 036500         05  FILLER  PIC X.
  2086. 036600         05  PLOT-SIZ-EST-INGR-DL1B3B  PIC X(5).
  2087. 036700         05  FILLER  PIC X.
  2088. 036800         05  PLOT-SIZ-EST-FRC-DL1B3B  PIC XX.
  2089. 036900         05  FILLER  PIC X.
  2090. 037000         05  PLANT-CD-DL1B3B  PIC X(7).
  2091. 037100         05  FILLER  PIC XX.
  2092. 037200         05  HGT-CLS-CD-DL1B3B  PIC X.
  2093. 037300         05  FILLER  PIC X(5).
  2094. 037400         05  GRP1-DL1B3B  OCCURS 10 TIMES.
  2095. 037500             07  CLS-PLANT-AVAIL-DL1B3B  PIC X.
  2096. 037600             07  PHNO-STG-DL1B3B  PIC X.
  2097. 037700             07  CLS-PLANT-UTIL-DL1B3B  PIC X.
  2098. 037800             07  HRBG-PROD-WGT-DL1B3B  PIC XXXX.
  2099. 037900             07  FILLER  PIC X.
  2100. 038000 01  HOLD-AREA.
  2101. 038100     03  ADST-CD-T-ACTN-CD-V11H.
  2102. 038200         05  ADST-CD-T-TRN-NUM-V11H.
  2103. 038300             07  ADST-DIST-PLU-CDS-V11H.
  2104. 038400                 09  ADST-CD-V11H  PIC XX  VALUE SPACES.
  2105. 038500                 09  DIST-CD-V11H  PIC XX.
  2106. 038600                 09  PLU-CD-V11H  PIC XX.
  2107. 038700             07  ALLOT-NUM-T-TRN-NUM-V11H.
  2108. 038800                 09  ALLOT-NUM-V11H  PIC XXXX.
  2109. 038900                 09  SWA-V11H.
  2110. 039000                     11  SWA-CD-V11H  PIC X.
  2111. 039100                     11  SWA-NUM-V11H  PIC XXX.
  2112. 039200                 09  TRN-NUM-V11H  PIC XX.
  2113. 039300         05  REC-TYP-T-FMT-CD-V11H  PIC XXXX.
  2114. 039400         05  ACTN-CD-V11H  PIC X.
  2115. 039500     03  ADST-CD-T-ACTN-CD-V11X-H  PIC X(21).
  2116. 039600     03  ADST-DIST-RA-PLU-CDS-H.
  2117. 039700         05  ADST-DIST-CDS-H.
  2118. 039800             07  ADST-CD-H  PIC XX.
  2119. 039900             07  DIST-CD-H  PIC XX.
  2120. 040000         05  RA-CD-H.
  2121. 040100             07  RA-CD-C1-H  PIC 9.
  2122. 040200             07  FILLER  PIC 9  VALUE 8.
  2123. 040300         05  PLU-CD-H  PIC XX.
  2124. 040400     03  DE-CD-EXPLN-8827-DECE-H.
  2125. 040500         05  DIST-NAM-H  PIC X(12).
  2126. 040600         05  RA-NAM-H  PIC X(13).
  2127. 040700         05  PLU-NAM-H  PIC X(15).
  2128. 040800     03  CODE-DEC-H.
  2129. 040900         05  FILLER  PIC XXXX.
  2130. 041000         05  PLANT-CD-H  PIC X(7).
  2131. 041100         05  FILLER  PIC X(24).
  2132. 041200         05  PLANT-TYP-H  PIC X.
  2133. 041300     03  DE-CD-NAM-8823-DEC-H.
  2134. 041400         05  ST-NAM-H  PIC X(10).
  2135. 041500         05  FILLER  PIC X(14).
  2136. 041600     03  DAT-H.
  2137. 041700         05  YER-H  PIC XX.
  2138. 041800         05  MON-H  PIC 99.
  2139. 041900         05  DAY-H  PIC XX.
  2140. 042000     03  GRP-V3XBX-H.
  2141. 042100         05  CLS-PLANT-AVAIL-V3XBX-H  PIC X.
  2142. 042200         05  PHNO-STG-V3XBX-H  PIC X.
  2143. 042300         05  CLS-PLANT-UTIL-V3XBX-H  PIC X.
  2144. 042400         05  HRBG-PROD-WGT-V3XBX-H  PIC XXXX.
  2145. 042500     03  INGR-3C-FRC-2C-H  PIC 999V99.
  2146. 042600     03  I3F2-H  REDEFINES  INGR-3C-FRC-2C-H.
  2147. 042700         05  INGR-3C-FRC-1C-H  PIC 999V9.
  2148. 042800         05  I3F1-H  REDEFINES  INGR-3C-FRC-1C-H.
  2149. 042900             07  FILLER  PIC X.
  2150. 043000             07  INGR-2C-FRC-1C-H  PIC 99V9.
  2151. 043100         05  FILLER  PIC X.
  2152. 043200     03  INGR-FRC-H  REDEFINES  INGR-3C-FRC-2C-H.
  2153. 043300         05  INGR-H  PIC XXX.
  2154. 043400         05  FRC-H  PIC XX.
  2155. 043500     03  PLANT-CD-V13AX-H.
  2156. 043600         05  PLANT-CD-C1-V13AX-H  PIC X.
  2157. 043700         05  PLANT-CD-LST-8C-V13AX-H  PIC X(8).
  2158. 043800     03  PC-V13AX-H  REDEFINES  PLANT-CD-V13AX-H.
  2159. 043900         05  PLANT-CD-1ST-8C-V13AX-H  PIC X(8).
  2160. 044000         05  FILLER  PIC X.
  2161. 044100     03  1C-PLANT-CD-V13AX-H  REDEFINES  PLANT-CD-V13AX-H
  2162. 044200             PIC X  OCCURS 9 TIMES.
  2163. 044300     03  PLANT-CD-V13AZ-H.
  2164. 044400         05  PLANT-CD-1ST-7C-V13AZ-H.
  2165. 044500             07  PLANT-CD-C1-V13AZ-H  PIC X.
  2166. 044600             07  PLANT-CD-C2T7-V13AZ-H  PIC X(6).
  2167. 044700         05  1C-PLANT-CD-V13AZ-H  REDEFINES
  2168. 044800                 PLANT-CD-1ST-7C-V13AZ-H  PIC X  OCCURS 7 TIMES.
  2169. 044900         05  LEV-TRN-HIT-V13AZ-H  PIC X.
  2170. 045000         05  FILLER  PIC X.
  2171. 045100     03  PLOT-SIZ-EST-V3XBX-H.
  2172. 045200         05  FILLER  PIC XX.
  2173. 045300         05  PLOT-SIZ-EST-D3XBZ-H  PIC 999V99.
  2174. 045400         05  PLOT-SIZ-C3T7-V3XBX-H  REDEFINES
  2175. 045500                 PLOT-SIZ-EST-D3XBZ-H.
  2176. 045600             07  PLOT-SIZ-C3T5-V3XBX-H  PIC XXX.
  2177. 045700             07  PLOT-SIZ-C6T7-V3XBX-H  PIC XX.
  2178. 045800     03  SSF-VAL-RAT-V14AX-H  PIC XX.
  2179. 045900     03  TYP-GC-HITS-V13AX-H  PIC XXX.
  2180. 046000     03  1C-PLANT-CD-H  PIC X.
  2181. 046100 01  KEY-LIN1A.
  2182. 046200     03  FILLER  PIC X(10)  VALUE SPACES.
  2183. 046300     03  ADST-CD-KL1A  PIC XX.
  2184. 046400     03  FILLER  PIC XXXX  VALUE SPACES.
  2185. 046500     03  DIST-CD-KL1A  PIC XX.
  2186. 046600     03  FILLER  PIC XXXX  VALUE SPACES.
  2187. 046700     03  PLU-CD-KL1A  PIC XX.
  2188. 046800     03  FILLER  PIC XXXX  VALUE SPACES.
  2189. 046900     03  ALLOT-NUM-KL1A  PIC XXXX.
  2190. 047000     03  FILLER  PIC XXXX  VALUE SPACES.
  2191. 047100     03  SWA-KL1A  PIC XXXX.
  2192. 047200     03  FILLER  PIC XXXX  VALUE SPACES.
  2193. 047300     03  TRN-NUM-KL1A  PIC XX.
  2194. 047400     03  FILLER  PIC X(86)  VALUE SPACES.
  2195. 047500 01  KEY-LIN1B.
  2196. 047600     03  FILLER  PIC X(10)  VALUE SPACES.
  2197. 047700     03  KEY-LIN1B1.
  2198. 047800         05  ADST-CD-KL1B  PIC XX.
  2199. 047900         05  FILLER  PIC XXXX.
  2200. 048000         05  DIST-CD-KL1B  PIC XX.
  2201. 048100         05  FILLER  PIC XXXX.
  2202. 048200         05  PLU-CD-KL1B  PIC XX.
  2203. 048300     03  FILLER  PIC XXXX  VALUE SPACES.
  2204. 048400     03  KEY-LIN1B2.
  2205. 048500         05  ALLOT-NUM-KL1B  PIC XXXX.
  2206. 048600         05  FILLER  PIC XXXX.
  2207. 048700         05  SWA-CD-KL1B  PIC X.
  2208. 048800         05  SWA-NUM-KL1B  PIC XXX.
  2209. 048900         05  FILLER  PIC XXXX.
  2210. 049000         05  TRN-NUM-KL1B  PIC XX.
  2211. 049100     03  FILLER  PIC X(86)  VALUE SPACES.
  2212. 049200 01  LTRL-AREA.
  2213. 049300     03  10ASTRKS-L  VALUE ALL "*".
  2214. 049400         05  09ASTRKS-L.
  2215. 049500             07  07ASTRKS-L.
  2216. 049600                 09  06ASTRKS-L.
  2217. 049700                     11  05ASTRKS-L.
  2218. 049800                         13  04ASTRKS-L.
  2219. 049900                             15  03ASTRKS-L.
  2220. 050000                                 17  02ASTRKS-L.
  2221. 050100                                     19  01ASTRK-L  PIC X.
  2222. 050200                                     19  FILLER  PIC X.
  2223. 050300                                 17  FILLER  PIC X.
  2224. 050400                             15  FILLER  PIC X.
  2225. 050500                         13  FILLER  PIC X.
  2226. 050600                     11  FILLER  PIC X.
  2227. 050700                 09  FILLER  PIC X.
  2228. 050800             07  FILLER  PIC XX.
  2229. 050900         05  FILLER  PIC X.
  2230. 051000 01  PAG-HDR1.
  2231. 051100     03  FILLER  PIC X(24)  VALUE "    PCN:          AS OF ".
  2232. 051200     03  DAY-PH1  PIC XX.
  2233. 051300     03  FILLER  PIC X  VALUE SPACE.
  2234. 051400     03  MON-PH1  PIC XXX.
  2235. 051500     03  FILLER  PIC X  VALUE SPACE.
  2236. 051600     03  YER-PH1  PIC XX.
  2237. 051700     03  FILLER  PIC X(09)  VALUE SPACES.
  2238. 051800     03  FILLER  PIC X(48)  VALUE "USDI- BUR OF LAND MGT  ECOLOGIC
  2239. 051900-                                 "AL SITE INVENTORY".
  2240. 052000     03  FILLER  PIC X(29)  VALUE SPACES.
  2241. 052100     03  FILLER  PIC X(6)  VALUE "PAGE: ".
  2242. 052200     03  PAG-CNT-PH1  PIC ZZ9.
  2243. 052300     03  FILLER  PIC XXXX  VALUE SPACES.
  2244. 052400 01  PAG-HDR2.
  2245. 052500     03  FILLER  PIC X(11)  VALUE "    STATE: ".
  2246. 052600     03  ADST-NAM-PH2  PIC X(10).
  2247. 052700     03  FILLER  PIC X(17)  VALUE "       RES AREA: ".
  2248. 052800     03  RA-CD-PH2  PIC XX.
  2249. 052900     03  FILLER  PIC X  VALUE SPACE.
  2250. 053000     03  RA-NAM-PH2  PIC X(13).
  2251. 053100     03  FILLER  PIC X(78)  VALUE SPACES.
  2252. 053200 01  PAG-HDR3.
  2253. 053300     03  FILLER  PIC X(11)  VALUE "    DIST:  ".
  2254. 053400     03  DIST-NAM-PH3  PIC X(12).
  2255. 053500     03  FILLER  PIC X(15)  VALUE "     PLNG UT:  ".
  2256. 053600     03  PLU-CD-PH3  PIC XX.
  2257. 053700     03  FILLER  PIC X  VALUE SPACE.
  2258. 053800     03  PLU-NAM-PH3  PIC X(15).
  2259. 053900     03  FILLER  PIC X(76)  VALUE SPACES.
  2260. 054000 01  PAG-HDR4.
  2261. 054100     03  FILLER  PIC X(50)  VALUE SPACES.
  2262. 054200     03  FILLER  PIC X(33)  VALUE "V1, V2, AND V3 EDIT ERROR LISTI
  2263. 054300-                                 "NG".
  2264. 054400     03  FILLER  PIC X(49)  VALUE SPACES.
  2265. 054500 01  PAG-HDR5.
  2266. 054600     03  FILLER  PIC X(17)  VALUE SPACES.
  2267. 054700     03  FILLER  PIC X(97)  VALUE "KEY COMMON DATA (1-44) IN ALL R
  2268. 054800-                              "ECORDS.  IF ERROR IN COMMON DATA (
  2269. 054900-                              "9-24), KEY ALL RECORDS IN SWA/T.".
  2270. 055000     03  FILLER  PIC X(18)  VALUE SPACES.
  2271. 055100 01  PAG-HDR6.
  2272. 055200     03  FILLER  PIC X(17)  VALUE SPACES.
  2273. 055300     03  FILLER  PIC X(99)  VALUE "IF ERROR IN OTHER COMMON DATA,
  2274. 055400-                             "KEY ALL OF THE RECORD - ELSE KEY AS
  2275. 055500-                             "TERISK AND RED CORRECTION FIELDS.".
  2276. 055600     03  FILLER  PIC X(16)  VALUE SPACES.
  2277. 055700 01  TABL-AREA.
  2278. 055800     03  MON-V  PIC X(36)  VALUE   "JANFEBMARAPRMAYJUNJULAUGSEPOCT
  2279. 055900-                                  "NOVDEC".
  2280. 056000     03  MON-T  REDEFINES  MON-V  PIC XXX  OCCURS 12 TIMES.
  2281. 056100     03  SSF-VAL-RAT-V  PIC X(14)  VALUE "14141414151415".
  2282. 056200     03  SSF-VAL-RAT-T  REDEFINES  SSF-VAL-RAT-V
  2283. 056300         PIC XX  OCCURS 7 TIMES.
  2284. 056400 01  V11X.
  2285. 056500     03  BATCH-NUM-V11X  PIC XXXX.
  2286. 056600     03  REC-TYP-T-FMT-CD-V11X.
  2287. 056700         05  REC-TYP-V11X  PIC XX.
  2288. 056800         05  FMT-NUM-V11X  PIC X.
  2289. 056900         05  FMT-CD-V11X  PIC X.
  2290. 057000     03  ADST-CD-T-TRN-NUM-V11X.
  2291. 057100         05  ADST-DIST-PLU-CDS-V11X  PIC X(6).
  2292. 057200         05  ALLOT-NUM-T-TRN-NUM-V11X  PIC X(10).
  2293. 057300     03  ACTN-CD-V11X  PIC X.
  2294. 057400     03  LIN-NUM-V11X  PIC XXX.
  2295. 057500     03  FILLER  PIC X.
  2296. 057600     03  SWA-BRWD-V11X.
  2297. 057700         05  SWA-CD-BRWD-V11X  PIC X.
  2298. 057800         05  SWA-NUM-BRWD-V11X  PIC XXX.
  2299. 057900         05  TRN-NUM-BRWD-V11X  PIC XX.
  2300. 058000     03  RA-CD-V11X  PIC XX.
  2301. 058100     03  FILLER  PIC X(7).
  2302. 058200     03  V11AX.
  2303. 058300         05  RNG-SITE-ID-V11AX  PIC X(11).
  2304. 058400         05  RNG-ECOL-COND-CLS-V11AX  PIC X.
  2305. 058500         05  VEG-SUB-TYP-V11AX  PIC XXXX.
  2306. 058600         05  SWA-PCT-V11AX  PIC XXX.
  2307. 058700         05  DATA-DAT-V11AX.
  2308. 058800             07  DATA-YER-V11AX  PIC XX.
  2309. 058900             07  DATA-MON-V11AX  PIC XX.
  2310. 059000             07  DATA-DAY-V11AX  PIC XX.
  2311. 059100         05  RECER-INTLS-V11AX  PIC XXX.
  2312. 059200         05  PHOTO-ID-V11AX  PIC X(16).
  2313. 059300         05  CMPR-ID-V11AX.
  2314. 059400             07  ADST-DIST-CDS-CMPR-V11AX.
  2315. 059500                 09  ADST-CD-CMPR-V11AX  PIC XX.
  2316. 059600                 09  DIST-CD-CMPR-V11AX  PIC XX.
  2317. 059700             07  TWP-CMPR-V11AX.
  2318. 059800                 09  TWP-NUM-CMPR-V11AX  PIC XXX.
  2319. 059900                 09  TWP-FRC-CMPR-V11AX  PIC X.
  2320. 060000                 09  TWP-DIR-CMPR-V11AX  PIC X.
  2321. 060100             07  RNG-CMPR-V11AX.
  2322. 060200                 09  RNG-NUM-CMPR-V11AX  PIC XXX.
  2323. 060300                 09  RNG-FRC-CMPR-V11AX  PIC X.
  2324. 060400                 09  RNG-DIR-CMPR-V11AX  PIC X.
  2325. 060500             07  CONS-NUM-CMPR-V11AX  PIC XX.
  2326. 060600         05  FILLER  PIC X(40).
  2327. 060700     03  V12AX  REDEFINES  V11AX.
  2328. 060800         05  TYP-GC-CD-V12AX  PIC X.
  2329. 060900         05  TYP-GC-HITS-V12AX  PIC XXX.
  2330. 061000         05  PLANT-CD-V12AX  PIC X(7)  OCCURS 4 TIMES.
  2331. 061100         05  FILLER  PIC X(68).
  2332. 061200     03  V13AX  REDEFINES  V11AX.
  2333. 061300         05  GRP1-V13AX.
  2334. 061400             07  FILLER  PIC X(39).
  2335. 061500             07  PLANT-CDS-TYP-GC-HITS-V13AX  PIC X(39).
  2336. 061600         05  GRP2-V13AX  REDEFINES  GRP1-V13AX  OCCURS 2 TIMES.
  2337. 061700             07  PLANT-CD-V13AX  PIC X(9)  OCCURS 4 TIMES.
  2338. 061800             07  TYP-GC-HITS-V13AX  PIC XXX.
  2339. 061900         05  FILLER  PIC X(22).
  2340. 062000     03  V14AX  REDEFINES  V11AX.
  2341. 062100         05  SSF-VAL-RAT-V14AX  PIC XX  OCCURS 7 TIMES.
  2342. 062200         05  FILLER  PIC X(86).
  2343. 062300     03  V21AX  REDEFINES  V11AX.
  2344. 062400         05  PLOT-SIZ-V21AX  PIC X.
  2345. 062500         05  PLOT-NUM-V21AX  PIC XX.
  2346. 062600         05  PLOT-NUM-V21AR  REDEFINES  PLOT-NUM-V21AX  PIC 99.
  2347. 062700         05  PLANT-CD-V21AX  PIC X(7).
  2348. 062800         05  AGE-CLS-PLANT-V21AX  PIC X.
  2349. 062900         05  FORM-CLS-PLANT-V21AX  PIC X.
  2350. 063000         05  PHNO-STG-V21AX  PIC X.
  2351. 063100         05  CLS-PLANT-AVAIL-V21AX  PIC X.
  2352. 063200         05  CLS-PLANT-UTIL-V21AX  PIC X.
  2353. 063300         05  AVG-HGT-PLANT-V21AX.
  2354. 063400             07  AVG-HGT-PLANT-INGR-V21AX  PIC XXX.
  2355. 063500             07  AVG-HGT-PLANT-FRC-V21AX  PIC XX.
  2356. 063600         05  CHARZD-NUM-V21AX  PIC XXX.
  2357. 063700         05  AVG-LDR-LGT-V21AX.
  2358. 063800             07  AVG-LDR-LGT-INGR-V21AX  PIC XXX.
  2359. 063900             07  AVG-LDR-LGT-FRC-V21AX  PIC XX.
  2360. 064000         05  AVG-CRN-DIA-V21AX.
  2361. 064100             07  AVG-CRN-DIA-INGR-V21AX  PIC XXX.
  2362. 064200             07  AVG-CRN-DIA-FRC-V21AX  PIC XX.
  2363. 064300         05  CHARZD-NOT-NUM-V21AX  PIC XXX.
  2364. 064400         05  MAST-CROPS-CD-V21AX  PIC X.
  2365. 064500         05  FILLER  PIC X(63).
  2366. 064600     03  V3XBX  REDEFINES  V11AX.
  2367. 064700         05  PLOT-TOT-NUM-V3XBX  PIC XX.
  2368. 064800         05  PLOT-SIZ-EST-V3XBX.
  2369. 064900             07  PLOT-SIZ-EST-INGR-V3XBX  PIC X(5).
  2370. 065000             07  PLOT-SIZ-EST-FRC-V3XBX  PIC XX.
  2371. 065100         05  PLANT-CD-V3XBX  PIC X(7).
  2372. 065200         05  HGT-CLS-CD-V3XBX  PIC X.
  2373. 065300         05  GRP-V3XBX  OCCURS 10 TIMES.
  2374. 065400             07  CLS-PLANT-AVAIL-V3XBX  PIC X.
  2375. 065500             07  PHNO-STG-V3XBX  PIC X.
  2376. 065600             07  CLS-PLANT-UTIL-V3XBX  PIC X.
  2377. 065700             07  HRBG-PROD-WGT-V3XBX  PIC XXXX.
  2378. 065800         05  FILLER  PIC X(13).
  2379. 065900 01  V11Z.
  2380. 066000     03  BATCH-NUM-V11Z  PIC 9999.
  2381. 066100     03  REC-TYP-V11Z  PIC XX.
  2382. 066200     03  FMT-NUM-V11Z  PIC 9.
  2383. 066300     03  FMT-CD-V11Z  PIC X.
  2384. 066400     03  ADST-CD-V11Z  PIC XX.
  2385. 066500     03  DIST-CD-V11Z  PIC 99.
  2386. 066600     03  PLU-CD-V11Z  PIC 99.
  2387. 066700     03  ALLOT-NUM-V11Z  PIC 9999.
  2388. 066800     03  SWA-V11Z.
  2389. 066900         05  SWA-CD-V11Z  PIC X.
  2390. 067000         05  SWA-NUM-V11Z  PIC 999.
  2391. 067100     03  TRN-NUM-V11Z  PIC 99.
  2392. 067200     03  ACTN-CD-V11Z  PIC X.
  2393. 067300     03  LIN-NUM-V11Z  PIC 999.
  2394. 067400     03  FILLER  PIC X.
  2395. 067500     03  SWA-BRWD-V11Z.
  2396. 067600         05  SWA-CD-BRWD-V11Z  PIC X.
  2397. 067700         05  SWA-NUM-BRWD-V11Z  PIC XXX.
  2398. 067800         05  TRN-NUM-BRWD-V11Z  PIC XX.
  2399. 067900     03  RA-CD-V11Z  PIC XX.
  2400. 068000     03  FILLER  PIC X(7).
  2401. 068100     03  V11AZ.
  2402. 068200         05  RNG-SITE-ID-V11AZ  PIC X(11).
  2403. 068300         05  RNG-ECOL-COND-CLS-V11AZ  PIC X.
  2404. 068400         05  VEG-SUB-TYP-V11AZ  PIC 9999.
  2405. 068500         05  SWA-PCT-V11AZ  PIC 999.
  2406. 068600         05  DATA-DAT-V11AZ  PIC X(6).
  2407. 068700         05  RECER-INTLS-V11AZ  PIC XXX.
  2408. 068800         05  PHOTO-ID-V11AZ  PIC X(16).
  2409. 068900         05  CMPR-ID-V11AZ.
  2410. 069000             07  ADST-CD-CMPR-V11AZ  PIC XX.
  2411. 069100             07  DIST-CD-CMPR-V11AZ  PIC 99.
  2412. 069200             07  TWP-CMPR-V11AZ.
  2413. 069300                 09  TWP-NUM-CMPR-V11AZ  PIC 999.
  2414. 069400                 09  TWP-FRC-CMPR-V11AZ  PIC 9.
  2415. 069500                 09  TWP-DIR-CMPR-V11AZ  PIC X.
  2416. 069600             07  RNG-CMPR-V11AZ.
  2417. 069700                 09  RNG-NUM-CMPR-V11AZ  PIC 999.
  2418. 069800                 09  RNG-FRC-CMPR-V11AZ  PIC 9.
  2419. 069900                 09  RNG-DIR-CMPR-V11AZ  PIC X.
  2420. 070000             07  CONS-NUM-CMPR-V11AZ  PIC 99.
  2421. 070100         05  FILLER  PIC X(35).
  2422. 070200     03  V12AZ  REDEFINES  V11AZ.
  2423. 070300         05  TYP-GC-CD-V12AZ  PIC X.
  2424. 070400         05  TYP-GC-HITS-V12AZ  PIC 999.
  2425. 070500         05  GRP1-V12AZ.
  2426. 070600             07  GRP2-V12AZ  OCCURS 4 TIMES.
  2427. 070700                 09  PLANT-TYP-V12AZ  PIC X.
  2428. 070800                 09  PLANT-CD-V12AZ  PIC X(7).
  2429. 070900         05  FILLER  PIC X(59).
  2430. 071000     03  V13AZ  REDEFINES  V11AZ.
  2431. 071100         05  GRP-V13AZ  OCCURS 2 TIMES.
  2432. 071200             07  PLANT-CD-V13AZ  PIC X(9)  OCCURS 4 TIMES.
  2433. 071300             07  TYP-GC-HITS-V13AZ  PIC 999.
  2434. 071400         05  FILLER  PIC X(17).
  2435. 071500     03  V14AZ  REDEFINES  V11AZ.
  2436. 071600         05  SSF-VAL-RAT-V14AZ  PIC XX  OCCURS 7 TIMES.
  2437. 071700         05  SSF-VAL-AVG-V14AZ  PIC XXX.
  2438. 071800         05  FILLER  PIC X(78).
  2439. 071900     03  V21AZ  REDEFINES  V11AZ.
  2440. 072000         05  PLOT-SIZ-V21AZ  PIC 9.
  2441. 072100         05  PLOT-NUM-V21AZ  PIC 99.
  2442. 072200         05  PLANT-CD-V21AZ  PIC X(7).
  2443. 072300         05  AGE-CLS-PLANT-V21AZ  PIC X.
  2444. 072400         05  FORM-CLS-PLANT-V21AZ  PIC 9.
  2445. 072500         05  PHNO-STG-V21AZ  PIC 9.
  2446. 072600         05  CLS-PLANT-AVAIL-V21AZ  PIC X.
  2447. 072700         05  CLS-PLANT-UTIL-V21AZ  PIC 9.
  2448. 072800         05  GRP-V21AZ.
  2449. 072900             07  AVG-HGT-PLANT-V21AZ  PIC 999V9.
  2450. 073000             07  CHARZD-NUM-V21AZ  PIC 999.
  2451. 073100             07  AVG-LDR-LGT-V21AZ  PIC 99V9.
  2452. 073200             07  FILLER  PIC X.
  2453. 073300             07  AVG-CRN-DIA-V21AZ  PIC 99V9.
  2454. 073400             07  FILLER  PIC X.
  2455. 073500             07  CHARZD-NOT-NUM-V21AZ  PIC 999.
  2456. 073600             07  MAST-CROPS-CD-V21AZ  PIC X.
  2457. 073700             07  FILLER  PIC XXX.
  2458. 073800         05  FILLER  PIC X(57).
  2459. 073900         05  PLANT-TYP-V21AZ  PIC X.
  2460. 074000     03  V3XBZ  REDEFINES  V11AZ.
  2461. 074100         05  PLOT-TOT-NUM-V3XBZ  PIC 99.
  2462. 074200         05  PLOT-SIZ-EST-V3XBZ  PIC 999V99.
  2463. 074300         05  PLOT-SIZ-FIL-V3XBZ  PIC XX.
  2464. 074400         05  PLANT-CD-V3XBZ  PIC X(7).
  2465. 074500         05  HGT-CLS-CD-V3XBZ  PIC 9.
  2466. 074600         05  GRP-V3XBZ  OCCURS 10 TIMES.
  2467. 074700             07  CLS-PLANT-AVAIL-V3XBZ  PIC X.
  2468. 074800             07  PHNO-STG-T-PROD-WGT-V3XBZ.
  2469. 074900                 09  PHNO-STG-V3XBZ  PIC 9.
  2470. 075000                 09  CLS-PLANT-UTIL-V3XBZ  PIC 9.
  2471. 075100                 09  HRBG-PROD-WGT-V3XBZ  PIC 9999.
  2472. 075200         05  FILLER  PIC X(7).
  2473. 075300         05  PLANT-TYP-V3XBZ  PIC X.
  2474. 075400     03  FILLER  PIC X(5).
  2475. 075500 PROCEDURE DIVISION.
  2476. 075600 START-PARA.
  2477. 075700     MOVE SPACE TO PLT-TABLE.
  2478. 075800     MOVE ZERO TO PLT-TABLE-2.
  2479. 075900     ACCEPT DAT-H FROM DATE.  MOVE DAY-H TO DAY-PH1.
  2480. 076000     MOVE MON-T (MON-H) TO MON-PH1.  MOVE YER-H TO YER-PH1.
  2481. 076100     OPEN INPUT  FIL-I1,
  2482. 076200          OUTPUT FIL-D1, FIL-P1.  READY DIC-DE.
  2483. 076300 0100.
  2484. 076400     READ FIL-I1  AT END
  2485. 076500         GO TO 9950-WRAP-UP.
  2486. 076600     IF SDP-I1 = "CO0710"
  2487. 076700         MOVE "CO0709" TO SDP-I1.
  2488. 076800     IF SDP-I1 = "NM0303"
  2489. 076900         MOVE "NM0305" TO SDP-I1.
  2490. 077000     IF SDP-I1 = "WY0425"
  2491. 077100         MOVE "WY0435" TO SDP-I1.
  2492. 077200     IF SDP-I1 = "WY0324" OR "WY0335"
  2493. 077300         MOVE "WY0323" TO SDP-I1.
  2494. 077400     ADD 1 TO IN-CNTR.  MOVE REC-I1 TO V11X, V11Z.
  2495. 077500     IF ADST-CD-T-TRN-NUM-V11H = ADST-CD-T-TRN-NUM-V11X
  2496. 077600         GO TO 0600.
  2497. 077700     MOVE ZERO TO KEY-FLG.  MOVE 1 TO RITE-HDR-FLG, RITE-KEY-FLG.
  2498. 077800     IF ADST-DIST-PLU-CDS-V11H = ADST-DIST-PLU-CDS-V11X
  2499. 077900         GO TO 0500.  MOVE ZERO TO PAG-CNT.
  2500. 078000     MOVE 0003 TO DE-NO-8801-DEC.  MOVE 48 TO LIN-CHK.
  2501. 078100     MOVE SPACES TO KEY-LIN1B1, RA-CD-PH2.
  2502. 078200     MOVE "UNKNOWN   " TO ADST-NAM-PH2, DIST-NAM-PH3,
  2503. 078300         RA-NAM-PH2, PLU-NAM-PH3.
  2504. 078400     MOVE ADST-DIST-PLU-CDS-V11X TO ADST-DIST-PLU-CDS-V11H.
  2505. 078500     MOVE PLU-CD-V11H TO PLU-CD-H, PLU-CD-KL1A, PLU-CD-PH3.
  2506. 078600     MOVE DIST-CD-V11H TO DIST-CD-H, DIST-CD-KL1A.
  2507. 078700     MOVE ADST-CD-V11H TO ADST-CD-H, ADST-CD-KL1A, DE-CD-8822-DEC.
  2508. 078800     FIND ANY CODE-DEC.
  2509. 078900     IF DB-STATUS NOT = ZERO  MOVE 02ASTRKS-L TO
  2510. 079000         ADST-CD-KL1B, DIST-CD-KL1B, PLU-CD-KL1B
  2511. 079100             MOVE 1 TO KEY-FLG  GO TO 0500.
  2512. 079200     GET CODE-DEC.
  2513. 079300     MOVE DE-CD-NAM-8823-DEC TO DE-CD-NAM-8823-DEC-H.
  2514. 079400     MOVE ST-NAM-H TO ADST-NAM-PH2.
  2515. 079500     MOVE ADST-DIST-CDS-H TO DE-CD-8822-DEC.
  2516. 079600     FIND ANY CODE-DEC.
  2517. 079700     IF DB-STATUS NOT = ZERO  MOVE 02ASTRKS-L TO
  2518. 079800         DIST-CD-KL1B, PLU-CD-KL1B
  2519. 079900             MOVE 1 TO KEY-FLG  GO TO 0500.
  2520. 080000     GET CODE-DEC.  FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  2521. 080100     IF DB-STATUS NOT = ZERO  MOVE 02ASTRKS-L TO
  2522. 080200         DIST-CD-KL1B, PLU-CD-KL1B
  2523. 080300             MOVE 1 TO KEY-FLG  GO TO 0500.
  2524. 080400     GET CODE-EXPL-DECE.
  2525. 080500     MOVE DE-CD-EXPLN-8827-DECE TO DE-CD-EXPLN-8827-DECE-H.
  2526. 080600     MOVE DIST-NAM-H TO DIST-NAM-PH3.  MOVE 4 TO RA-CD-C1-H.
  2527. 080700 0300.
  2528. 080800     MOVE ADST-DIST-RA-PLU-CDS-H TO DE-CD-8822-DEC.
  2529. 080900     FIND ANY CODE-DEC.
  2530. 081000     IF DB-STATUS NOT = ZERO  GO TO 0400.
  2531. 081100     GET CODE-DEC.  FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  2532. 081200     IF DB-STATUS = ZERO  GET CODE-EXPL-DECE
  2533. 081300         MOVE DE-CD-EXPLN-8827-DECE TO DE-CD-EXPLN-8827-DECE-H
  2534. 081400         MOVE RA-CD-H TO RA-CD-PH2  MOVE RA-NAM-H TO RA-NAM-PH2
  2535. 081500         MOVE PLU-NAM-H TO PLU-NAM-PH3  GO TO 0500.
  2536. 081600 0400.
  2537. 081700     IF RA-CD-C1-H < 8  ADD 1 TO RA-CD-C1-H  GO TO 0300.
  2538. 081800*    MOVE 02ASTRKS-L TO PLU-CD-KL1B.  MOVE 1 TO KEY-FLG.
  2539. 081900     ADD 1 TO CNT-BAD-PU.
  2540. 082000 0500.
  2541. 082100     MOVE SPACES TO KEY-LIN1B2.
  2542. 082200     MOVE ALLOT-NUM-T-TRN-NUM-V11X TO ALLOT-NUM-T-TRN-NUM-V11H.
  2543. 082300     MOVE ALLOT-NUM-V11H TO ALLOT-NUM-KL1A.
  2544. 082400     MOVE SWA-V11H TO SWA-KL1A.
  2545. 082500     MOVE TRN-NUM-V11H TO TRN-NUM-KL1A.
  2546. 082600     IF ALLOT-NUM-V11H NOT NUMERIC
  2547. 082700*        MOVE 04ASTRKS-L TO ALLOT-NUM-KL1B  MOVE 1 TO KEY-FLG.
  2548. 082800         ADD 1 TO CNT-BAD-ALOT.
  2549. 082900     IF SWA-CD-V11H NOT ALPHABETIC OR SWA-CD-V11H = SPACE
  2550. 083000         MOVE 01ASTRK-L TO SWA-CD-KL1B  MOVE 1 TO KEY-FLG.
  2551. 083100     IF SWA-NUM-V11H NOT NUMERIC
  2552. 083200         MOVE 03ASTRKS-L TO SWA-NUM-KL1B  MOVE 1 TO KEY-FLG.
  2553. 083300     IF TRN-NUM-V11H NOT NUMERIC
  2554. 083400         MOVE 02ASTRKS-L TO TRN-NUM-KL1B  MOVE 1 TO KEY-FLG.
  2555. 083500 0600.
  2556. 083600     MOVE RA-CD-H TO RA-CD-V11X, RA-CD-V11Z.
  2557. 083700     MOVE KEY-FLG TO DATA-FLG.
  2558. 083800     IF ACTN-CD-V11X = "A"  GO TO 0700.
  2559. 083900     IF ACTN-CD-V11X = "R"
  2560. 084000         MOVE ZERO TO LIN-NUM-V11Z  GO TO 0800.
  2561. 084100     IF LIN-NUM-V11X NOT NUMERIC OR LIN-NUM-V11X = ZERO
  2562. 084200         MOVE 03ASTRKS-L TO LIN-NUM-DL1B
  2563. 084300         MOVE 1 TO DATA-FLG.  GO TO 0800.
  2564. 084400 0700.
  2565. 084500     MOVE REC-TYP-T-FMT-CD-V11X TO REC-TYP-T-FMT-CD-V11H.
  2566. 084600     MOVE ACTN-CD-V11X TO ACTN-CD-V11H.
  2567. 084700     IF ADST-CD-T-ACTN-CD-V11H NOT = ADST-CD-T-ACTN-CD-V11X-H
  2568. 084800         MOVE ADST-CD-T-ACTN-CD-V11H TO ADST-CD-T-ACTN-CD-V11X-H
  2569. 084900         MOVE ZERO TO LIN-NUM-H.
  2570. 085000     ADD 1 TO LIN-NUM-H.
  2571. 085100 0800.
  2572. 085200     IF (CNT-BAD-TYPE > 25) OR (CNT-BAD-FORM > 25) OR
  2573. 085300         (CNT-BAD-CODE > 25)
  2574. 085400         DISPLAY "                                       "
  2575. 085500         DISPLAY "ABORT ABORT ABORT ABORT ABORT ABORT ABORT"
  2576. 085600         DISPLAY "                                       "
  2577. 085700         GO TO 9950-WRAP-UP.
  2578. 085800     IF REC-TYP-V11X = "V2"  GO TO 5000.
  2579. 085900     IF REC-TYP-V11X = "V3"  GO TO 6000.
  2580. 086000     IF REC-TYP-V11X NOT = "V1"
  2581. 086100         ADD 1 TO CNT-BAD-TYPE
  2582. 086200         DISPLAY "BAD REC TYPE= " V11X
  2583. 086300         GO TO 0100.
  2584. 086400     ADD 1 TO CNT-V1.
  2585. 086500     IF FMT-NUM-V11X = "2"  GO TO 2000.
  2586. 086600     IF FMT-NUM-V11X = "3"  MOVE 1 TO SS1A, SS1B  GO TO 3000.
  2587. 086700     IF FMT-NUM-V11X = "4"  MOVE 1 TO SS1A  GO TO 4000.
  2588. 086800     IF FMT-NUM-V11X NOT = "1"
  2589. 086900         ADD 1 TO CNT-BAD-FORM
  2590. 087000         DISPLAY "BAD REC FORM= " V11X
  2591. 087100         GO TO 0100.
  2592. 087200     IF SWA-BRWD-V11X = SPACES  GO TO 0900.
  2593. 087300     IF SWA-CD-BRWD-V11X NOT ALPHABETIC
  2594. 087400         OR SWA-CD-BRWD-V11X = SPACE
  2595. 087500             MOVE 01ASTRK-L TO SWA-CD-BRWD-DL1B11
  2596. 087600             MOVE 1 TO DATA-FLG.
  2597. 087700     IF SWA-NUM-BRWD-V11X NOT NUMERIC
  2598. 087800         MOVE 03ASTRKS-L TO SWA-NUM-BRWD-DL1B11
  2599. 087900         MOVE 1 TO DATA-FLG.
  2600. 088000     IF TRN-NUM-BRWD-V11X NOT NUMERIC
  2601. 088100         MOVE 02ASTRKS-L TO TRN-NUM-BRWD-DL1B11
  2602. 088200         MOVE 1 TO DATA-FLG.
  2603. 088300     IF DATA-FLG ZERO  MOVE SPACES TO V11AZ  GO TO 7000.
  2604. 088400     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
  2605. 088500         MOVE COL-HDRA11 TO COL-HDR2A1
  2606. 088600         MOVE COL-HDRB11 TO COL-HDR2B1
  2607. 088700         MOVE COL-HDRC11 TO COL-HDR2C1
  2608. 088800         MOVE 1 TO RITE-HDR-FLG.
  2609. 088900     MOVE SWA-BRWD-V11X TO SWA-BRWD-DL1A11.  GO TO 7100.
  2610. 089000 0900.
  2611. 089100     IF DATA-YER-V11AX NOT NUMERIC
  2612. 089200         MOVE 02ASTRKS-L TO DATA-YER-DL1B11
  2613. 089300         MOVE 1 TO DATA-FLG.
  2614. 089400     IF DATA-MON-V11AX NOT NUMERIC
  2615. 089500         OR DATA-MON-V11AX < "01" OR > "12"
  2616. 089600             MOVE 02ASTRKS-L TO DATA-MON-DL1B11
  2617. 089700             MOVE 1 TO DATA-FLG.
  2618. 089800     IF DATA-DAY-V11AX NOT NUMERIC
  2619. 089900         OR DATA-DAY-V11AX < "01" OR > "31"
  2620. 090000             MOVE 02ASTRKS-L TO DATA-DAY-DL1B11
  2621. 090100             MOVE 1 TO DATA-FLG.
  2622. 090200     IF DAT-H NOT > DATA-DAT-V11AX
  2623. 090300         MOVE 06ASTRKS-L TO DATA-DAT-DL1B11
  2624. 090400         MOVE 1 TO DATA-FLG.
  2625. 090500     IF ADST-DIST-CDS-CMPR-V11AX = SPACES  GO TO 1400.
  2626. 090600     MOVE 0003 TO DE-NO-8801-DEC.
  2627. 090700     MOVE ADST-CD-CMPR-V11AX TO DE-CD-8822-DEC.
  2628. 090800     FIND ANY CODE-DEC.
  2629. 090900     IF DB-STATUS NOT = ZERO
  2630. 091000         MOVE 02ASTRKS-L TO ADST-CD-CMPR-DL1B11
  2631. 091100         MOVE 1 TO DATA-FLG.
  2632. 091200     MOVE ADST-DIST-CDS-CMPR-V11AX TO DE-CD-8822-DEC.
  2633. 091300     FIND ANY CODE-DEC.
  2634. 091400     IF DB-STATUS NOT = ZERO
  2635. 091500         MOVE 02ASTRKS-L TO DIST-CD-CMPR-DL1B11
  2636. 091600         MOVE 1 TO DATA-FLG.
  2637. 091700 1400.
  2638. 091800     IF CONS-NUM-CMPR-V11AX = SPACES
  2639. 091900         MOVE ZERO TO CONS-NUM-CMPR-V11AZ
  2640. 092000     ELSE IF CONS-NUM-CMPR-V11AX NOT NUMERIC
  2641. 092100         OR CONS-NUM-CMPR-V11AX NOT > ZERO
  2642. 092200             MOVE 02ASTRKS-L TO CONS-NUM-CMPR-DL1B11
  2643. 092300             MOVE 1 TO DATA-FLG.
  2644. 092400     IF DATA-FLG NOT ZERO  GO TO 1500.
  2645. 092500     IF VEG-SUB-TYP-V11AX = SPACES
  2646. 092600         MOVE ZERO TO VEG-SUB-TYP-V11AZ.
  2647. 092700     MOVE DATA-DAT-V11AX TO DATA-DAT-V11AZ.
  2648. 092800     IF DIST-CD-CMPR-V11AX = SPACES
  2649. 092900         MOVE ZERO TO DIST-CD-CMPR-V11AZ.
  2650. 093000     IF TWP-NUM-CMPR-V11AX = SPACES
  2651. 093100         MOVE ZERO TO TWP-NUM-CMPR-V11AZ.
  2652. 093200     IF TWP-FRC-CMPR-V11AX = SPACE
  2653. 093300         MOVE ZERO TO TWP-FRC-CMPR-V11AZ.
  2654. 093400     IF RNG-NUM-CMPR-V11AX = SPACES
  2655. 093500         MOVE ZERO TO RNG-NUM-CMPR-V11AZ.
  2656. 093600     IF RNG-FRC-CMPR-V11AX = SPACE
  2657. 093700         MOVE ZERO TO RNG-FRC-CMPR-V11AZ.  GO TO 7000.
  2658. 093800 1500.
  2659. 093900     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
  2660. 094000         MOVE COL-HDRA11 TO COL-HDR2A1
  2661. 094100         MOVE COL-HDRB11 TO COL-HDR2B1
  2662. 094200         MOVE COL-HDRC11 TO COL-HDR2C1
  2663. 094300         MOVE 1 TO RITE-HDR-FLG.
  2664. 094400     MOVE RNG-SITE-ID-V11AX TO RNG-SITE-ID-DL1A11.
  2665. 094500     MOVE RNG-ECOL-COND-CLS-V11AX TO RNG-ECOL-COND-CLS-DL1A11.
  2666. 094600     MOVE VEG-SUB-TYP-V11AX TO VEG-SUB-TYP-DL1A11.
  2667. 094700     MOVE SWA-PCT-V11AX TO SWA-PCT-DL1A11.
  2668. 094800     MOVE DATA-DAT-V11AX TO DATA-DAT-DL1A11.
  2669. 094900     MOVE RECER-INTLS-V11AX TO RECER-INTLS-DL1A11.
  2670. 095000     MOVE PHOTO-ID-V11AX TO PHOTO-ID-DL1A11.
  2671. 095100     MOVE ADST-CD-CMPR-V11AX TO ADST-CD-CMPR-DL1A11.
  2672. 095200     MOVE DIST-CD-CMPR-V11AX TO DIST-CD-CMPR-DL1A11.
  2673. 095300     MOVE TWP-CMPR-V11AX TO TWP-CMPR-DL1A11.
  2674. 095400     MOVE RNG-CMPR-V11AX TO RNG-CMPR-DL1A11.
  2675. 095500     MOVE CONS-NUM-CMPR-V11AX TO CONS-NUM-CMPR-DL1A11.
  2676. 095600     GO TO 7100.
  2677. 095700 2000.
  2678. 095800     MOVE SPACES TO GRP1-V12AZ.  MOVE 1 TO SS1A.
  2679. 095900     IF TYP-GC-HITS-V12AX = SPACES OR ZERO
  2680. 096000         MOVE ZERO TO TYP-GC-HITS-V12AZ  GO TO 2200.
  2681. 096100     IF TYP-GC-CD-V12AX NOT =
  2682. 096200         "B" AND "C" AND "G" AND "N" AND "P" AND "R" AND "S"
  2683. 096300             MOVE 01ASTRK-L TO TYP-GC-CD-DL1B12
  2684. 096400             MOVE 1 TO DATA-FLG.
  2685. 096500     IF TYP-GC-HITS-V12AX NOT NUMERIC
  2686. 096600         MOVE 03ASTRKS-L TO TYP-GC-HITS-DL1B12
  2687. 096700         MOVE 1 TO DATA-FLG.  GO TO 2200.
  2688. 096800 2100.
  2689. 096900     IF TYP-GC-CD-V12AX NOT = SPACE AND
  2690. 097000         "B" AND "C" AND "G" AND "N" AND "P" AND "R" AND "S"
  2691. 097100             MOVE 01ASTRK-L TO TYP-GC-CD-DL1B12
  2692. 097200             MOVE 1 TO DATA-FLG.
  2693. 097300 2200.
  2694. 097400     MOVE PLANT-CD-V12AX (SS1A) TO PLT-HLD.
  2695. 097500     PERFORM 9900-PLT-CNV.
  2696. 097600     MOVE PLT-HLD TO PLANT-CD-V12AX (SS1A).
  2697. 097700     MOVE PLANT-CD-V12AX (SS1A) TO DE-CD-8822-DEC.
  2698. 097800     IF DE-CD-8822-DEC = SPACES  GO TO 2400.
  2699. 097900     PERFORM 9200.  IF PLANT-CD-FLG NOT ZERO
  2700. 098000         MOVE 07ASTRKS-L TO PLANT-CD-DL1B12 (SS1A)
  2701. 098100         MOVE 1 TO DATA-FLG
  2702. 098200     ELSE MOVE PLANT-TYP-H TO PLANT-TYP-V12AZ (SS1A)
  2703. 098300         MOVE PLANT-CD-H TO PLANT-CD-V12AZ (SS1A).
  2704. 098400 2400.
  2705. 098500     IF SS1A < 4  ADD 1 TO SS1A  GO TO 2200.
  2706. 098600     IF DATA-FLG ZERO  GO TO 7000.
  2707. 098700     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
  2708. 098800         MOVE COL-HDRA12 TO COL-HDR2A1
  2709. 098900         MOVE COL-HDRB12 TO COL-HDR2B1
  2710. 099000         MOVE COL-HDRC12 TO COL-HDR2C1
  2711. 099100         MOVE 1 TO RITE-HDR-FLG.
  2712. 099200     MOVE TYP-GC-CD-V12AX TO TYP-GC-CD-DL1A12.
  2713. 099300     MOVE TYP-GC-HITS-V12AX TO TYP-GC-HITS-DL1A12.
  2714. 099400     MOVE 1 TO SS1A.
  2715. 099500 2800.
  2716. 099600     MOVE PLANT-CD-V12AX (SS1A) TO PLANT-CD-DL1A12 (SS1A).
  2717. 099700     IF SS1A < 4  ADD 1 TO SS1A  GO TO 2800.
  2718. 099800     GO TO 7100.
  2719. 099900 3000.
  2720. 100000     MOVE PLANT-CD-V13AX (SS1A, SS1B) TO PLT-HLD.
  2721. 100100     PERFORM 9900-PLT-CNV.
  2722. 100200     MOVE PLT-HLD TO PLANT-CD-V13AX (SS1A, SS1B).
  2723. 100300     MOVE PLANT-CD-V13AX (SS1A, SS1B) TO PLANT-CD-V13AX-H.
  2724. 100400     IF PLANT-CD-V13AX-H = SPACES  GO TO 3800.
  2725. 100500     IF PLANT-CD-LST-8C-V13AX-H NOT = SPACES  GO TO 3300.
  2726. 100600     IF PLANT-CD-C1-V13AX-H NOT = "B" AND "C" AND "G" AND "L"
  2727. 100700         AND "M" AND "N" AND "P" AND "R" AND "S"
  2728. 100800             MOVE 09ASTRKS-L TO PLANT-CD-DL1B13 (SS1A, SS1B)
  2729. 100900             MOVE 1 TO DATA-FLG.  GO TO 3800.
  2730. 101000 3300.
  2731. 101100     MOVE PLANT-CD-1ST-8C-V13AX-H TO DE-CD-8822-DEC.
  2732. 101200     PERFORM 9200.  IF PLANT-CD-FLG ZERO  GO TO 3800.
  2733. 101300     MOVE SPACES TO PLANT-CD-V13AZ-H.
  2734. 101400     MOVE 1 TO SS1C, SS1D.
  2735. 101500 3600.
  2736. 101600     MOVE 1C-PLANT-CD-V13AX-H (SS1C) TO 1C-PLANT-CD-H.
  2737. 101700     IF 1C-PLANT-CD-H = "(" OR ")"  MOVE SPACE TO 1C-PLANT-CD-H
  2738. 101800         MOVE "*" TO LEV-TRN-HIT-V13AZ-H.
  2739. 101900     IF 1C-PLANT-CD-H NOT = SPACE  MOVE 1C-PLANT-CD-H
  2740. 102000         TO 1C-PLANT-CD-V13AZ-H (SS1D)  ADD 1 TO SS1D.
  2741. 102100     IF SS1C < 9  ADD 1 TO SS1C  GO TO 3600.
  2742. 102200     IF PLANT-CD-C2T7-V13AZ-H NOT = SPACES  GO TO 3700.
  2743. 102300     IF PLANT-CD-C1-V13AZ-H = "B" OR "C" OR "G" OR "L" OR "M"
  2744. 102400         OR "N" OR "P" OR "R" OR "S"
  2745. 102500             MOVE PLANT-CD-V13AZ-H TO PLANT-CD-V13AZ (SS1A, SS1B)
  2746. 102600                 GO TO 3800.
  2747. 102700     MOVE 09ASTRKS-L TO PLANT-CD-DL1B13 (SS1A, SS1B).
  2748. 102800     MOVE 1 TO DATA-FLG.  GO TO 3800.
  2749. 102900 3700.
  2750. 103000     MOVE PLANT-CD-1ST-7C-V13AZ-H TO DE-CD-8822-DEC.
  2751. 103100     PERFORM 9200.  IF PLANT-CD-FLG NOT ZERO
  2752. 103200         MOVE 09ASTRKS-L TO PLANT-CD-DL1B13 (SS1A, SS1B)
  2753. 103300         MOVE 1 TO DATA-FLG
  2754. 103400     ELSE MOVE PLANT-CD-V13AZ-H TO PLANT-CD-V13AZ (SS1A, SS1B).
  2755. 103500 3800.
  2756. 103600     IF SS1B < 4  ADD 1 TO SS1B  GO TO 3000.
  2757. 103700     MOVE TYP-GC-HITS-V13AX (SS1A) TO TYP-GC-HITS-V13AX-H.
  2758. 103800     IF TYP-GC-HITS-V13AX-H NOT NUMERIC
  2759. 103900         OR TYP-GC-HITS-V13AX-H NOT > ZERO
  2760. 104000             MOVE 03ASTRKS-L TO TYP-GC-HITS-DL1B13 (SS1A)
  2761. 104100             MOVE 1 TO DATA-FLG.
  2762. 104200     IF SS1A < 2 AND PLANT-CDS-TYP-GC-HITS-V13AX NOT = SPACES
  2763. 104300         MOVE 2 TO SS1A  MOVE 1 TO SS1B  GO TO 3000.
  2764. 104400     IF DATA-FLG NOT ZERO  GO TO 3850.
  2765. 104500     IF TYP-GC-HITS-V13AX (SS1A) = SPACES
  2766. 104600         MOVE ZERO TO TYP-GC-HITS-V13AZ (SS1A).  GO TO 7000.
  2767. 104700 3850.
  2768. 104800     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
  2769. 104900         MOVE COL-HDRA13 TO COL-HDR2A1
  2770. 105000         MOVE COL-HDRB13 TO COL-HDR2B1
  2771. 105100         MOVE COL-HDRC13 TO COL-HDR2C1
  2772. 105200         MOVE 1 TO RITE-HDR-FLG.
  2773. 105300     MOVE 1 TO SS1A, SS1B.
  2774. 105400 3900.
  2775. 105500     MOVE PLANT-CD-V13AX (SS1A, SS1B)
  2776. 105600          TO PLANT-CD-DL1A13 (SS1A, SS1B).
  2777. 105700     IF SS1B < 4  ADD 1 TO SS1B  GO TO 3900.
  2778. 105800     MOVE TYP-GC-HITS-V13AX (SS1A) TO TYP-GC-HITS-DL1A13 (SS1A).
  2779. 105900     IF SS1A < 2 AND PLANT-CDS-TYP-GC-HITS-V13AX NOT = SPACES
  2780. 106000         MOVE 2 TO SS1A  MOVE 1 TO SS1B  GO TO 3900.
  2781. 106100     GO TO 7100.
  2782. 106200 4000.
  2783. 106300     MOVE SSF-VAL-RAT-V14AX (SS1A) TO SSF-VAL-RAT-V14AX-H.
  2784. 106400     IF SSF-VAL-RAT-V14AX-H = SPACES
  2785. 106500         MOVE "99" TO SSF-VAL-RAT-V14AX (SS1A)
  2786. 106600             SSF-VAL-RAT-V14AZ (SS1A)  GO TO 4500.
  2787. 106700     IF SSF-VAL-RAT-V14AX-H = "NA" OR "99"
  2788. 106800         OR SSF-VAL-RAT-V14AX-H NUMERIC
  2789. 106900         AND SSF-VAL-RAT-V14AX-H NOT > SSF-VAL-RAT-T (SS1A)
  2790. 107000             GO TO 4500.
  2791. 107100     MOVE 02ASTRKS-L TO SSF-VAL-RAT-DL1B14 (SS1A).
  2792. 107200     MOVE 1 TO DATA-FLG.
  2793. 107300 4500.
  2794. 107400     IF SS1A < 7  ADD 1 TO SS1A  GO TO 4000.
  2795. 107500     IF DATA-FLG ZERO
  2796. 107600         MOVE SPACES TO SSF-VAL-AVG-V14AZ  GO TO 7000.
  2797. 107700     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
  2798. 107800         MOVE COL-HDRA14 TO COL-HDR2A1
  2799. 107900         MOVE COL-HDRB14 TO COL-HDR2B1
  2800. 108000         MOVE COL-HDRC14 TO COL-HDR2C1
  2801. 108100         MOVE 1 TO RITE-HDR-FLG.
  2802. 108200     MOVE 1 TO SS1A.
  2803. 108300 4800.
  2804. 108400     MOVE SSF-VAL-RAT-V14AX (SS1A) TO SSF-VAL-RAT-DL1A14 (SS1A).
  2805. 108500     IF SS1A < 7  ADD 1 TO SS1A  GO TO 4800.
  2806. 108600     GO TO 7100.
  2807. 108700 5000.
  2808. 108800     ADD 1 TO CNT-V2.
  2809. 108900     MOVE PLANT-CD-V21AX  TO PLT-HLD.
  2810. 109000     PERFORM 9900-PLT-CNV.
  2811. 109100     MOVE PLT-HLD TO PLANT-CD-V21AX .
  2812. 109200     IF PLANT-CD-V21AX = "BARREN "
  2813. 109300         MOVE SPACES TO V21AZ  MOVE ZERO TO PLOT-SIZ-V21AZ,
  2814. 109400             FORM-CLS-PLANT-V21AZ, PHNO-STG-V21AZ,
  2815. 109500             CLS-PLANT-UTIL-V21AZ, AVG-HGT-PLANT-V21AZ,
  2816. 109600             AVG-LDR-LGT-V21AZ, AVG-CRN-DIA-V21AZ,
  2817. 109700             CHARZD-NOT-NUM-V21AZ
  2818. 109800         MOVE PLOT-NUM-V21AR TO PLOT-NUM-V21AZ
  2819. 109900         MOVE PLANT-CD-V21AX TO PLANT-CD-V21AZ
  2820. 110000         MOVE 001 TO CHARZD-NUM-V21AZ  GO TO 7000.
  2821. 110100     IF PLOT-SIZ-V21AX NOT = "1" AND "2"
  2822. 110200         MOVE 01ASTRK-L TO PLOT-SIZ-DL1B21
  2823. 110300         MOVE 1 TO DATA-FLG.
  2824. 110400     IF PLOT-NUM-V21AX NOT NUMERIC
  2825. 110500         OR PLOT-NUM-V21AX < "01" OR > "40"
  2826. 110600             MOVE 02ASTRKS-L TO PLOT-NUM-DL1B21
  2827. 110700             MOVE 1 TO DATA-FLG.
  2828. 110800     MOVE PLANT-CD-V21AX TO DE-CD-8822-DEC.
  2829. 110900     PERFORM 9200.  IF PLANT-CD-FLG NOT ZERO
  2830. 111000         MOVE 07ASTRKS-L TO PLANT-CD-DL1B21
  2831. 111100         MOVE 1 TO DATA-FLG
  2832. 111200     ELSE MOVE PLANT-TYP-H TO PLANT-TYP-V21AZ.
  2833. 111300 5100.
  2834. 111400     IF FORM-CLS-PLANT-V21AX NOT = "5"  GO TO 5150.
  2835. 111500     IF AGE-CLS-PLANT-V21AX NOT = SPACE
  2836. 111600         MOVE 01ASTRK-L TO AGE-CLS-PLANT-DL1B21
  2837. 111700         MOVE 1 TO DATA-FLG.
  2838. 111800     IF PHNO-STG-V21AX NOT = SPACE
  2839. 111900         MOVE 01ASTRK-L TO PHNO-STG-DL1B21
  2840. 112000         MOVE 1 TO DATA-FLG.
  2841. 112100     IF CLS-PLANT-AVAIL-V21AX NOT = SPACE
  2842. 112200         MOVE 01ASTRK-L TO CLS-PLANT-AVAIL-DL1B21
  2843. 112300         MOVE 1 TO DATA-FLG.
  2844. 112400     IF CLS-PLANT-UTIL-V21AX NOT = SPACE
  2845. 112500         MOVE 01ASTRK-L TO CLS-PLANT-UTIL-DL1B21
  2846. 112600         MOVE 1 TO DATA-FLG.
  2847. 112700     IF AVG-HGT-PLANT-INGR-V21AX NOT = SPACE
  2848. 112800         MOVE 03ASTRKS-L TO AVG-HGT-PLANT-INGR-DL1B21
  2849. 112900         MOVE 1 TO DATA-FLG.
  2850. 113000     IF AVG-HGT-PLANT-FRC-V21AX NOT = SPACE
  2851. 113100         MOVE 02ASTRKS-L TO AVG-HGT-PLANT-FRC-DL1B21
  2852. 113200         MOVE 1 TO DATA-FLG.
  2853. 113300     IF AVG-LDR-LGT-INGR-V21AX NOT = SPACE
  2854. 113400         MOVE 03ASTRKS-L TO AVG-LDR-LGT-INGR-DL1B21
  2855. 113500         MOVE 1 TO DATA-FLG.
  2856. 113600     IF AVG-LDR-LGT-FRC-V21AX NOT = SPACE
  2857. 113700         MOVE 02ASTRKS-L TO AVG-LDR-LGT-FRC-DL1B21
  2858. 113800         MOVE 1 TO DATA-FLG.
  2859. 113900     IF AVG-CRN-DIA-INGR-V21AX NOT = SPACE
  2860. 114000         MOVE 03ASTRKS-L TO AVG-CRN-DIA-INGR-DL1B21
  2861. 114100         MOVE 1 TO DATA-FLG.
  2862. 114200     IF AVG-CRN-DIA-FRC-V21AX NOT = SPACE
  2863. 114300         MOVE 02ASTRKS-L TO AVG-CRN-DIA-FRC-DL1B21
  2864. 114400         MOVE 1 TO DATA-FLG.
  2865. 114500     IF DATA-FLG ZERO
  2866. 114600         MOVE ZERO TO PHNO-STG-V21AZ, CLS-PLANT-UTIL-V21AZ.
  2867. 114700     GO TO 5200.
  2868. 114800 5150.
  2869. 114900     IF AGE-CLS-PLANT-V21AX NOT = SPACE
  2870. 115000         AND "D" AND "M" AND "O" AND "P" AND "R" AND "S" AND "Y"
  2871. 115100             MOVE 01ASTRK-L TO AGE-CLS-PLANT-DL1B21
  2872. 115200             MOVE 1 TO DATA-FLG.
  2873. 115300     IF FORM-CLS-PLANT-V21AX = SPACE
  2874. 115400         MOVE ZERO TO FORM-CLS-PLANT-V21AZ
  2875. 115500     ELSE IF FORM-CLS-PLANT-V21AX < "1" OR > "4"
  2876. 115600         MOVE 01ASTRK-L TO FORM-CLS-PLANT-DL1B21
  2877. 115700         MOVE 1 TO DATA-FLG.
  2878. 115800     IF PHNO-STG-V21AX = SPACE  MOVE ZERO TO PHNO-STG-V21AZ
  2879. 115900     ELSE IF PHNO-STG-V21AX < "1" OR > "9"
  2880. 116000         MOVE 01ASTRK-L TO PHNO-STG-DL1B21  MOVE 1 TO DATA-FLG.
  2881. 116100     IF CLS-PLANT-AVAIL-V21AX NOT =
  2882. 116200         SPACE AND "A" AND "H" AND "L" AND "P" AND "U"
  2883. 116300             MOVE 01ASTRK-L TO CLS-PLANT-AVAIL-DL1B21
  2884. 116400             MOVE 1 TO DATA-FLG.
  2885. 116500     IF CLS-PLANT-UTIL-V21AX = SPACE
  2886. 116600         MOVE ZERO TO CLS-PLANT-UTIL-V21AZ
  2887. 116700     ELSE IF CLS-PLANT-UTIL-V21AX < ZERO OR > "5"
  2888. 116800         MOVE 01ASTRK-L TO CLS-PLANT-UTIL-DL1B21
  2889. 116900         MOVE 1 TO DATA-FLG.
  2890. 117000 5200.
  2891. 117100     MOVE SPACES TO GRP-V21AZ.
  2892. 117200     IF AVG-HGT-PLANT-V21AX = SPACES
  2893. 117300         MOVE ZERO TO AVG-HGT-PLANT-V21AZ  GO TO 5300.
  2894. 117400     MOVE AVG-HGT-PLANT-V21AX TO INGR-FRC-H.  PERFORM 9600.
  2895. 117500     IF INGR-FLG NOT ZERO
  2896. 117600         MOVE 03ASTRKS-L TO AVG-HGT-PLANT-INGR-DL1B21
  2897. 117700         MOVE 1 TO DATA-FLG.
  2898. 117800     IF FRC-FLG NOT ZERO
  2899. 117900         MOVE 02ASTRKS-L TO AVG-HGT-PLANT-FRC-DL1B21
  2900. 118000         MOVE 1 TO DATA-FLG.
  2901. 118100     IF DATA-FLG ZERO
  2902. 118200         MOVE INGR-3C-FRC-1C-H TO AVG-HGT-PLANT-V21AZ.
  2903. 118300 5300.
  2904. 118400     IF CHARZD-NUM-V21AX = SPACE
  2905. 118500         MOVE ZERO TO CHARZD-NUM-V21AZ
  2906. 118600     ELSE IF CHARZD-NUM-V21AX NUMERIC
  2907. 118700         MOVE CHARZD-NUM-V21AX TO CHARZD-NUM-V21AZ
  2908. 118800     ELSE MOVE 03ASTRKS-L TO CHARZD-NUM-DL1B21
  2909. 118900         MOVE 1 TO DATA-FLG.
  2910. 119000     IF AVG-LDR-LGT-V21AX = SPACES
  2911. 119100         MOVE ZERO TO AVG-LDR-LGT-V21AZ  GO TO 5400.
  2912. 119200     MOVE AVG-LDR-LGT-V21AX TO INGR-FRC-H.  PERFORM 9600.
  2913. 119300     IF INGR-FLG NOT ZERO
  2914. 119400         MOVE 03ASTRKS-L TO AVG-LDR-LGT-INGR-DL1B21
  2915. 119500         MOVE 1 TO DATA-FLG.
  2916. 119600     IF FRC-FLG NOT ZERO
  2917. 119700         MOVE 02ASTRKS-L TO AVG-LDR-LGT-FRC-DL1B21
  2918. 119800         MOVE 1 TO DATA-FLG.
  2919. 119900     IF DATA-FLG ZERO
  2920. 120000         MOVE INGR-2C-FRC-1C-H TO AVG-LDR-LGT-V21AZ.
  2921. 120100 5400.
  2922. 120200     IF AVG-CRN-DIA-V21AX = SPACES
  2923. 120300         MOVE ZERO TO AVG-CRN-DIA-V21AZ  GO TO 5500.
  2924. 120400     MOVE AVG-CRN-DIA-V21AX TO INGR-FRC-H.  PERFORM 9600.
  2925. 120500     IF INGR-FLG NOT ZERO
  2926. 120600         MOVE 03ASTRKS-L TO AVG-CRN-DIA-INGR-DL1B21
  2927. 120700         MOVE 1 TO DATA-FLG.
  2928. 120800     IF FRC-FLG NOT ZERO
  2929. 120900         MOVE 02ASTRKS-L TO AVG-CRN-DIA-FRC-DL1B21
  2930. 121000         MOVE 1 TO DATA-FLG.
  2931. 121100     IF DATA-FLG ZERO
  2932. 121200         MOVE INGR-2C-FRC-1C-H TO AVG-CRN-DIA-V21AZ.
  2933. 121300 5500.
  2934. 121400     IF CHARZD-NOT-NUM-V21AX = SPACE
  2935. 121500         MOVE ZERO TO CHARZD-NOT-NUM-V21AZ
  2936. 121600     ELSE IF CHARZD-NOT-NUM-V21AX NUMERIC
  2937. 121700         MOVE CHARZD-NOT-NUM-V21AX TO CHARZD-NOT-NUM-V21AZ
  2938. 121800     ELSE MOVE 03ASTRKS-L TO CHARZD-NOT-NUM-DL1B21
  2939. 121900         MOVE 1 TO DATA-FLG.
  2940. 122000     IF DATA-FLG ZERO
  2941. 122100         MOVE MAST-CROPS-CD-V21AX TO MAST-CROPS-CD-V21AZ
  2942. 122200             GO TO 7000.
  2943. 122300     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
  2944. 122400         MOVE COL-HDRA21 TO COL-HDR2A1
  2945. 122500         MOVE COL-HDRB21 TO COL-HDR2B1
  2946. 122600         MOVE COL-HDRC21 TO COL-HDR2C1
  2947. 122700         MOVE 1 TO RITE-HDR-FLG.
  2948. 122800     MOVE PLOT-SIZ-V21AX TO PLOT-SIZ-DL1A21.
  2949. 122900     MOVE PLOT-NUM-V21AX TO PLOT-NUM-DL1A21.
  2950. 123000     MOVE PLANT-CD-V21AX TO PLANT-CD-DL1A21.
  2951. 123100     MOVE AGE-CLS-PLANT-V21AX TO AGE-CLS-PLANT-DL1A21.
  2952. 123200     MOVE FORM-CLS-PLANT-V21AX TO FORM-CLS-PLANT-DL1A21.
  2953. 123300     MOVE PHNO-STG-V21AX TO PHNO-STG-DL1A21.
  2954. 123400     MOVE CLS-PLANT-AVAIL-V21AX TO CLS-PLANT-AVAIL-DL1A21.
  2955. 123500     MOVE CLS-PLANT-UTIL-V21AX TO CLS-PLANT-UTIL-DL1A21.
  2956. 123600     IF AVG-HGT-PLANT-V21AX NOT = SPACES
  2957. 123700         MOVE AVG-HGT-PLANT-INGR-V21AX
  2958. 123800             TO AVG-HGT-PLANT-INGR-DL1A21
  2959. 123900         MOVE "." TO AVG-HGT-PLANT-DEC-DL1A21
  2960. 124000         MOVE AVG-HGT-PLANT-FRC-V21AX TO AVG-HGT-PLANT-FRC-DL1A21.
  2961. 124100     MOVE CHARZD-NUM-V21AX TO CHARZD-NUM-DL1A21.
  2962. 124200     IF AVG-LDR-LGT-V21AX NOT = SPACES
  2963. 124300         MOVE AVG-LDR-LGT-INGR-V21AX TO AVG-LDR-LGT-INGR-DL1A21
  2964. 124400         MOVE "." TO AVG-LDR-LGT-DEC-DL1A21
  2965. 124500         MOVE AVG-LDR-LGT-FRC-V21AX TO AVG-LDR-LGT-FRC-DL1A21.
  2966. 124600     IF AVG-CRN-DIA-V21AX NOT = SPACES
  2967. 124700         MOVE AVG-CRN-DIA-INGR-V21AX TO AVG-CRN-DIA-INGR-DL1A21
  2968. 124800         MOVE "." TO AVG-CRN-DIA-DEC-DL1A21
  2969. 124900         MOVE AVG-CRN-DIA-FRC-V21AX TO AVG-CRN-DIA-FRC-DL1A21.
  2970. 125000     MOVE CHARZD-NOT-NUM-V21AX TO CHARZD-NOT-NUM-DL1A21.
  2971. 125100     MOVE MAST-CROPS-CD-V21AX TO MAST-CROPS-CD-DL1A21.
  2972. 125200     GO TO 7100.
  2973. 125300 6000.
  2974. 125400     ADD 1 TO CNT-V3.
  2975. 125500     IF FMT-CD-V11X NOT = "B"
  2976. 125600         ADD 1 TO CNT-BAD-CODE
  2977. 125700         DISPLAY "BAD REC CODE= " V11X
  2978. 125800         GO TO 0100 .
  2979. 125900*    ELSE DISPLAY V11X.
  2980. 126000     IF PLANT-CD-V3XBX NOT = "BARREN "  GO TO 6200.
  2981. 126100     MOVE SPACES TO V3XBZ.
  2982. 126200     MOVE ZERO TO PLOT-TOT-NUM-V3XBZ, PLOT-SIZ-EST-V3XBZ,
  2983. 126300                  HGT-CLS-CD-V3XBZ.
  2984. 126400     MOVE PLANT-CD-V3XBX TO PLANT-CD-V3XBZ.  MOVE 1 TO SS2A.
  2985. 126500 6100.
  2986. 126600     MOVE ZERO TO PHNO-STG-T-PROD-WGT-V3XBZ (SS2A).
  2987. 126700     IF SS2A < 10  ADD 1 TO SS2A  GO TO 6100.  GO TO 7000.
  2988. 126800 6200.
  2989. 126900     MOVE PLANT-CD-V3XBX TO PLT-HLD.
  2990. 127000     PERFORM 9900-PLT-CNV.
  2991. 127100     MOVE PLT-HLD TO PLANT-CD-V3XBX.
  2992. 127200     IF PLOT-TOT-NUM-V3XBX NOT NUMERIC
  2993. 127300         OR PLOT-TOT-NUM-V3XBX NOT > ZERO
  2994. 127400             MOVE 02ASTRKS-L TO PLOT-TOT-NUM-DL1B3B
  2995. 127500             MOVE 1 TO DATA-FLG.
  2996. 127600     MOVE PLOT-SIZ-EST-V3XBX TO PLOT-SIZ-EST-V3XBX-H.
  2997. 127700     PERFORM 9800.  IF INGR-FLG NOT ZERO
  2998. 127800         MOVE 05ASTRKS-L TO PLOT-SIZ-EST-INGR-DL1B3B
  2999. 127900         MOVE 1 TO DATA-FLG.
  3000. 128000     IF FRC-FLG NOT ZERO
  3001. 128100         MOVE 02ASTRKS-L TO PLOT-SIZ-EST-FRC-DL1B3B
  3002. 128200         MOVE 1 TO DATA-FLG.
  3003. 128300     MOVE PLANT-CD-V3XBX TO DE-CD-8822-DEC.
  3004. 128400     PERFORM 9200.  IF PLANT-CD-FLG NOT ZERO
  3005. 128500         MOVE 07ASTRKS-L TO PLANT-CD-DL1B3B
  3006. 128600         MOVE 1 TO DATA-FLG
  3007. 128700     ELSE MOVE PLANT-TYP-H TO PLANT-TYP-V3XBZ.
  3008. 128800     IF HGT-CLS-CD-V3XBX < "1" OR > "4"
  3009. 128900         MOVE 01ASTRK-L TO HGT-CLS-CD-DL1B3B
  3010. 129000         MOVE 1 TO DATA-FLG.  MOVE 1 TO SS2A.
  3011. 129100 6300.
  3012. 129200     MOVE GRP-V3XBX (SS2A) TO GRP-V3XBX-H.
  3013. 129300     IF HRBG-PROD-WGT-V3XBX-H = ZERO
  3014. 129400         MOVE SPACES TO HRBG-PROD-WGT-V3XBX-H.
  3015. 129500     IF GRP-V3XBX-H = SPACES
  3016. 129600         MOVE ZERO TO PHNO-STG-T-PROD-WGT-V3XBZ (SS2A)
  3017. 129700             GO TO 6400.
  3018. 129800     IF HRBG-PROD-WGT-V3XBX-H = SPACES
  3019. 129900         MOVE ZERO TO HRBG-PROD-WGT-V3XBZ (SS2A)
  3020. 130000     ELSE IF HRBG-PROD-WGT-V3XBX-H NOT NUMERIC
  3021. 130100         MOVE 04ASTRKS-L TO HRBG-PROD-WGT-DL1B3B (SS2A)
  3022. 130200         MOVE 1 TO DATA-FLG.
  3023. 130300     IF CLS-PLANT-AVAIL-V3XBX-H NOT =
  3024. 130400         "A" AND "H" AND "L" AND "P" AND "U"
  3025. 130500             MOVE 01ASTRK-L TO CLS-PLANT-AVAIL-DL1B3B (SS2A)
  3026. 130600             MOVE 1 TO DATA-FLG.
  3027. 130700     IF PHNO-STG-V3XBX-H < "1" OR > "8"
  3028. 130800         MOVE 01ASTRK-L TO PHNO-STG-DL1B3B (SS2A)
  3029. 130900         MOVE 1 TO DATA-FLG.
  3030. 131000     IF CLS-PLANT-UTIL-V3XBX-H NOT NUMERIC
  3031. 131100         OR CLS-PLANT-UTIL-V3XBX-H > "5"
  3032. 131200             MOVE 01ASTRK-L TO CLS-PLANT-UTIL-DL1B3B (SS2A)
  3033. 131300             MOVE 1 TO DATA-FLG.
  3034. 131400 6400.
  3035. 131500     IF SS2A < 10  ADD 1 TO SS2A  GO TO 6300.
  3036. 131600     IF DATA-FLG ZERO
  3037. 131700         MOVE PLOT-SIZ-EST-D3XBZ-H TO PLOT-SIZ-EST-V3XBZ
  3038. 131800         MOVE SPACES TO PLOT-SIZ-FIL-V3XBZ  GO TO 7000.
  3039. 131900     MOVE FMT-NUM-V11X TO FMT-NUM-DL1A.
  3040. 132000     IF REC-TYP-T-FMT-CD-DL1A NOT = REC-TYP-T-FMT-CD-V11X
  3041. 132100         MOVE COL-HDRA3B TO COL-HDR2A1
  3042. 132200         MOVE COL-HDRB3B TO COL-HDR2B1
  3043. 132300         MOVE COL-HDRC3B TO COL-HDR2C1
  3044. 132400         MOVE 1 TO RITE-HDR-FLG.
  3045. 132500     MOVE PLOT-TOT-NUM-V3XBX TO PLOT-TOT-NUM-DL1A3B.
  3046. 132600     IF PLOT-SIZ-EST-V3XBX NOT = SPACES
  3047. 132700         MOVE PLOT-SIZ-EST-INGR-V3XBX TO PLOT-SIZ-EST-INGR-DL1A3B
  3048. 132800         MOVE "." TO PLOT-SIZ-EST-DEC-DL1A3B
  3049. 132900         MOVE PLOT-SIZ-EST-FRC-V3XBX TO PLOT-SIZ-EST-FRC-DL1A3B.
  3050. 133000     MOVE PLANT-CD-V3XBX TO PLANT-CD-DL1A3B.
  3051. 133100     MOVE HGT-CLS-CD-V3XBX TO HGT-CLS-CD-DL1A3B.
  3052. 133200     MOVE 1 TO SS2A.
  3053. 133300 6500.
  3054. 133400     MOVE GRP-V3XBX (SS2A) TO GRP2-DL1A3B (SS2A).
  3055. 133500     IF SS2A < 10  ADD 1 TO SS2A  GO TO 6500.  GO TO 7100.
  3056. 133600 7000.
  3057. 133700     MOVE V11Z TO REC-D1.  WRITE REC-D1.
  3058. 133800     ADD 1 TO OT-CNTR.  GO TO 0100.
  3059. 133900 7100.
  3060. 134000     MOVE REC-TYP-T-FMT-CD-V11X
  3061. 134100         TO REC-TYP-T-FMT-CD-DL1A.
  3062. 134200     MOVE ACTN-CD-V11X TO ACTN-CD-DL1A.
  3063. 134300     MOVE LIN-NUM-V11X TO LIN-NUM-DL1A.
  3064. 134400 7200.
  3065. 134500     MOVE ZERO TO LIN-CNT.
  3066. 134600     IF RITE-HDR-FLG NOT ZERO  ADD 4 TO LIN-CNT.
  3067. 134700     IF RITE-KEY-FLG NOT ZERO  ADD 6 TO LIN-CNT
  3068. 134800         IF KEY-FLG NOT ZERO  ADD 1 TO LIN-CNT.
  3069. 134900     ADD 3 TO LIN-CNT.  ADD LIN-CNT TO LIN-CHK.
  3070. 135000     IF LIN-CHK > 48  ADD 1 TO PAG-CNT
  3071. 135100         MOVE PAG-CNT TO PAG-CNT-PH1  MOVE ZERO TO LIN-CHK
  3072. 135200         MOVE 1 TO RITE-HDR-FLG  MOVE PAG-HDR1 TO REC-P1
  3073. 135300         WRITE REC-P1 AFTER ADVANCING PAGE
  3074. 135400         MOVE PAG-HDR2 TO REC-P1
  3075. 135500         WRITE REC-P1 AFTER ADVANCING 2 LINES
  3076. 135600         MOVE PAG-HDR3 TO REC-P1  WRITE REC-P1
  3077. 135700         MOVE PAG-HDR4 TO REC-P1
  3078. 135800         WRITE REC-P1 AFTER ADVANCING 2 LINES
  3079. 135900         MOVE PAG-HDR5 TO REC-P1  WRITE REC-P1
  3080. 136000         MOVE PAG-HDR6 TO REC-P1  WRITE REC-P1  GO TO 7200.
  3081. 136100     IF RITE-KEY-FLG ZERO  GO TO 7400.
  3082. 136200     MOVE ZERO TO RITE-KEY-FLG.
  3083. 136300     MOVE COL-HDR1A TO REC-P1.
  3084. 136400     WRITE REC-P1 AFTER ADVANCING 2 LINES.
  3085. 136500     MOVE COL-HDR1B TO REC-P1.  WRITE REC-P1.
  3086. 136600     MOVE COL-HDR1C TO REC-P1.  WRITE REC-P1.
  3087. 136700     MOVE KEY-LIN1A TO REC-P1.
  3088. 136800     WRITE REC-P1 AFTER ADVANCING 2 LINES.
  3089. 136900     IF KEY-FLG NOT ZERO
  3090. 137000         MOVE KEY-LIN1B TO REC-P1  WRITE REC-P1.
  3091. 137100 7400.
  3092. 137200     IF RITE-HDR-FLG NOT ZERO
  3093. 137300         MOVE ZERO TO RITE-HDR-FLG
  3094. 137400         MOVE COL-HDR2A TO REC-P1
  3095. 137500         WRITE REC-P1 AFTER ADVANCING 2 LINES
  3096. 137600         MOVE COL-HDR2B TO REC-P1  WRITE REC-P1
  3097. 137700         MOVE COL-HDR2C TO REC-P1  WRITE REC-P1.
  3098. 137800     MOVE DATA-LIN1A TO REC-P1.
  3099. 137900     WRITE REC-P1 AFTER ADVANCING 2 LINES.
  3100. 138000     MOVE DATA-LIN1B TO REC-P1.  WRITE REC-P1.
  3101. 138100     MOVE SPACES TO DATA-LIN1A11, DATA-LIN1B11.
  3102. 138200     ADD 1 TO PT-CNTR.  GO TO 0100.
  3103. 138300 9200.
  3104. 138400     MOVE DE-CD-8822-DEC TO PLT-SRC.
  3105. 138500     MOVE ZERO TO PLANT-CD-FLG.  MOVE 2646 TO DE-NO-8801-DEC.
  3106. 138600     FIND ANY CODE-DEC.
  3107. 138700     IF DB-STATUS NOT = ZERO  MOVE 1 TO PLANT-CD-FLG
  3108. 138800     ELSE GET CODE-DEC
  3109. 138900         MOVE CODE-DEC TO CODE-DEC-H
  3110. 139000         IF PLANT-TYP-H NOT = "F" AND "G" AND "S" AND "T"
  3111. 139100             MOVE 1 TO PLANT-CD-FLG.
  3112. 139200     IF PLANT-CD-FLG = 1
  3113. 139300         PERFORM 9910-PLT-STORE THRU 9940-EXIT.
  3114. 139400 9600.
  3115. 139500     MOVE ZERO TO FRC-FLG, INGR-FLG.
  3116. 139600     EXAMINE INGR-FRC-H REPLACING ALL SPACES BY ZERO.
  3117. 139700     IF INGR-H NOT NUMERIC  MOVE 1 TO INGR-FLG.
  3118. 139800     IF FRC-H NOT NUMERIC  MOVE 1 TO FRC-FLG.
  3119. 139900     IF FRC-FLG ZERO AND INGR-FLG ZERO
  3120. 140000         ADD .05 TO INGR-3C-FRC-2C-H.
  3121. 140100 9800.
  3122. 140200     MOVE ZERO TO FRC-FLG, INGR-FLG.
  3123. 140300     EXAMINE PLOT-SIZ-C3T7-V3XBX-H REPLACING ALL SPACES BY ZERO.
  3124. 140400     IF PLOT-SIZ-C3T5-V3XBX-H NOT NUMERIC  MOVE 1 TO INGR-FLG.
  3125. 140500     IF PLOT-SIZ-C6T7-V3XBX-H NOT NUMERIC  MOVE 1 TO FRC-FLG.
  3126. 140600     IF PLOT-SIZ-EST-D3XBZ-H < .01  MOVE 1 TO FRC-FLG, INGR-FLG.
  3127. 140700 9900-PLT-CNV.
  3128. 140800     IF PLT-HLD = "MOSS   "
  3129. 140900         MOVE "MMMM   " TO PLT-HLD.
  3130. 141000     IF PLT-HLD = "RHRA   "
  3131. 141100         MOVE "TORY   " TO PLT-HLD.
  3132. 141200     IF PLT-HLD = "LICHEN "
  3133. 141300         MOVE "SILEN  " TO PLT-HLD.
  3134. 141400     IF PLT-HLD = "ARTRZ  "
  3135. 141500         MOVE "ARTR2  " TO PLT-HLD.
  3136. 141600     IF PLT-HLD = "CHDEZ  "
  3137. 141700         MOVE "CHDE2  " TO PLT-HLD.
  3138. 141800     IF PLT-HLD = "GIPOZ  "
  3139. 141900         MOVE "GIPO2  " TO PLT-HLD.
  3140. 142000     IF PLT-HLD = "CACRII "
  3141. 142100         MOVE "CHCR11 " TO PLT-HLD.
  3142. 142200     IF PLT-HLD = "CACRLL "
  3143. 142300         MOVE "CHCR11 " TO PLT-HLD.
  3144. 142400     IF PLT-HLD = "HAARZ  "
  3145. 142500         MOVE "HAAR2  " TO PLT-HLD.
  3146. 142600     IF PLT-HLD = "TESPZ  "
  3147. 142700         MOVE "TESP2  " TO PLT-HLD.
  3148. 142800     IF PLT-HLD = "PHLOZ  "
  3149. 142900         MOVE "PHLO2  " TO PLT-HLD.
  3150. 143000     IF PLT-HLD = "POATT  "
  3151. 143100         MOVE "POA++  " TO PLT-HLD.
  3152. 143200     IF PLT-HLD = "POA    "
  3153. 143300         MOVE "POA++  " TO PLT-HLD.
  3154. 143400     IF PLT-HLD = "EULAS  "
  3155. 143500         MOVE "EULA5  " TO PLT-HLD.
  3156. 143600*    IF PLT-HLD = "X"
  3157. 143700*        MOVE "Z" TO PLT-HLD.
  3158. 143800 9910-PLT-STORE.
  3159. 143900     MOVE 0 TO PLT-SUB.
  3160. 144000 9920-LP.
  3161. 144100     ADD 1 TO PLT-SUB.
  3162. 144200     IF PLT-SUB > 200 GO TO 9940-EXIT.
  3163. 144300     IF PLT-TB (PLT-SUB) = SPACE
  3164. 144400         MOVE PLT-SRC TO PLT-TB (PLT-SUB)
  3165. 144500         MOVE 1 TO PLT-CNT (PLT-SUB)
  3166. 144600         GO TO 9940-EXIT.
  3167. 144700     IF PLT-SRC = PLT-TB (PLT-SUB)
  3168. 144800         ADD 1 TO PLT-CNT (PLT-SUB)
  3169. 144900         GO TO 9940-EXIT.
  3170. 145000     GO TO 9920-LP.
  3171. 145100 9940-EXIT.
  3172. 145200     EXIT.
  3173. 145300 9950-WRAP-UP.
  3174. 145400     MOVE 0 TO PLT-SUB.
  3175. 145500 9960-LP.
  3176. 145600     ADD 1 TO PLT-SUB.
  3177. 145700     IF PLT-SUB > 200 GO TO 9970-STOP.
  3178. 145800     IF PLT-TB (PLT-SUB) = SPACE GO TO 9970-STOP.
  3179. 145900     DISPLAY PLT-TB (PLT-SUB) "   "  PLT-CNT (PLT-SUB).
  3180. 146000     GO TO 9960-LP.
  3181. 146100 9970-STOP.
  3182. 146200     DISPLAY "RECORDS OUT = ", OT-CNTR.
  3183. 146300     DISPLAY "BAD RECORDS = ", PT-CNTR.
  3184. 146400     DISPLAY "RECORDS IN  = ", IN-CNTR.
  3185. 146500     DISPLAY "V1 RECORDS  = " CNT-V1.
  3186. 146600     DISPLAY "V2 RECORDS  = " CNT-V2.
  3187. 146700     DISPLAY "V3 RECORDS  = " CNT-V3.
  3188. 146800     DISPLAY "BAD-PU-CNT  = " CNT-BAD-PU.
  3189. 146900     DISPLAY "BAD-ALOT-CNT= " CNT-BAD-PU.
  3190. 147000     CLOSE FIL-I1, FIL-D1, FIL-P1
  3191. 147100     FINISH DIC-DE
  3192. 147200     STOP RUN.
  3193. 000000*-----------------------------------------------------------------
  3194. 000100 IDENTIFICATION DIVISION.
  3195. 000200 PROGRAM-ID. ES040X.
  3196. 000300*        BUILDS WORK FILES FOR INPUT TO PLANT SUMMARY PROGRAM.
  3197. 000400*
  3198. 000500 AUTHOR. RON BAKER.
  3199. 000600 DATE-WRITTEN.  05/05/80.
  3200. 000700 DATE-COMPILED.
  3201. 000800 ENVIRONMENT DIVISION.
  3202. 000900 CONFIGURATION SECTION.
  3203. 001000 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  3204. 001100 OBJECT-COMPUTER.  LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
  3205. 001200 INPUT-OUTPUT SECTION.
  3206. 001300 FILE-CONTROL.
  3207. 001400     SELECT FILE-P1      ASSIGN TO P1
  3208. 001500         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  3209. 001600     SELECT FILE-D4      ASSIGN TO D4
  3210. 001700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  3211. 001800     SELECT FILE-D1      ASSIGN TO D1
  3212. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  3213. 002000     SELECT FILE-D2      ASSIGN TO D2
  3214. 002100         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  3215. 002200     SELECT FILE-D3      ASSIGN TO D3
  3216. 002300         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  3217. 002400 DATA DIVISION.
  3218. 002500 FILE SECTION.
  3219. 002600 FD  FILE-D4
  3220. 002700     CODE-SET IS GBCD
  3221. 002800     LABEL RECORDS ARE STANDARD
  3222. 002900     DATA RECORD IS FDR-D4.
  3223. 003000 01  FDR-D4.
  3224. 003100     03  FILLER   PIC XXXX.
  3225. 003200     03  REC-TYP-D4   PIC XXXX.
  3226. 003300     03  FILLER       PIC X(134).
  3227. 003400     03  PAST-NUM-D4-IN    PIC XX.
  3228. 003500 FD  FILE-D1
  3229. 003600     CODE-SET IS GBCD
  3230. 003700     LABEL RECORDS ARE STANDARD
  3231. 003800     DATA RECORD IS FDR-D1.
  3232. 003900 01  FDR-D1            PIC X(102).
  3233. 004000 FD  FILE-D2
  3234. 004100     CODE-SET IS GBCD
  3235. 004200     LABEL RECORDS ARE STANDARD
  3236. 004300     DATA RECORD IS FDR-D2.
  3237. 004400 01  FDR-D2            PIC X(24).
  3238. 004500 FD  FILE-D3
  3239. 004600     CODE-SET IS GBCD
  3240. 004700     LABEL RECORDS ARE STANDARD
  3241. 004800     DATA RECORD IS FDR-D3.
  3242. 004900 01  FDR-D3            PIC X(126).
  3243. 005000 FD  FILE-P1
  3244. 005100     CODE-SET IS GBCD
  3245. 005200     LABEL RECORDS ARE STANDARD
  3246. 005300     DATA RECORD IS FDR-P1.
  3247. 005400 01  FDR-P1.
  3248. 005500     03  SH-P    PIC X(20).
  3249. 005600     03  RC-P     PIC X(112).
  3250. 005700 WORKING-STORAGE SECTION.
  3251. 005800 77  SUB-03  PIC 99    VALUE ZERO.
  3252. 005900 77  REC-TYP-IN  PIC 9    VALUE ZERO.
  3253. 006000 77  WORK-STATUS    PIC XXX.
  3254. 006100 77  TAB-KEY-HLD  PIC 99    VALUE ZERO.
  3255. 006200 77  BY-2-SW  PIC 9    VALUE ZERO.
  3256. 006300 77  FIRST-RK9-SW  PIC 9    VALUE ZERO.
  3257. 006400 77  BY-2-SW  PIC 9    VALUE ZERO.
  3258. 006500 77  BY-SWAT-SW  PIC 9    VALUE ZERO.
  3259. 006600 77  BAD-SW     PIC 9  VALUE ZERO.
  3260. 006700 77  SUB-01  PIC 99    VALUE ZERO.
  3261. 006800 77  SUB-5   PIC 99    VALUE ZERO.
  3262. 006900 77  SLT-SUB PIC 99    VALUE ZERO.
  3263. 007000 77  TK-HLD  PIC 99    VALUE ZERO.
  3264. 007100 77  SUB-02  PIC 99    VALUE ZERO.
  3265. 007200 77  SUB-GC  PIC 99    VALUE ZERO.
  3266. 007300 77  SWAT-NO-REL    PIC X(20)  VALUE SPACE.
  3267. 007400 77  ALLOT-NUM-HLD     PIC 9999.
  3268. 007500     COPY V11Z OF LIBRARY1.
  3269. 007600 01  REC-KEY9.
  3270. 007700     03  SDRP-RK9.
  3271. 007800         05  ADST-CD-RK9      PIC XX.
  3272. 007900         05  DIST-CD-RK9      PIC 99.
  3273. 008000         05  RA-CD-RK9      PIC 99.
  3274. 008100         05  PLU-CD-RK9       PIC 99.
  3275. 008200     03  SWAT-RK9    PIC X(6).
  3276. 008300     03  REC-KEY-RK9    PIC 9.
  3277. 008400     03  PLOTS-RK9       PIC 99.
  3278. 008500     03  FILLER          PIC X(7).
  3279. 008600 01  CNTL-HLD.
  3280. 008700     03  SDRP-SH.
  3281. 008800         05  ADST-CD-SH      PIC XX.
  3282. 008900         05  DIST-CD-SH      PIC 99.
  3283. 009000         05  RA-CD-SH      PIC 99.
  3284. 009100         05  PLU-CD-SH       PIC 99.
  3285. 009200     03  ALLOT-NUM-SH    PIC 9999.
  3286. 009300     03  PASTURE-NUM-SH  PIC 99.
  3287. 009400     03  SWAT-SH.
  3288. 009500         05  SWA-SH.
  3289. 009600             07  SWA-CD      PIC X.
  3290. 009700             07  SWA-NUM     PIC 999.
  3291. 009800         05  TRN-NUM-SH     PIC 99.
  3292. 009900 01  CNTL-D4.
  3293. 010000     03  SDRP-D4.
  3294. 010100         05  ADST-CD-D4      PIC XX.
  3295. 010200         05  DIST-CD-D4      PIC 99.
  3296. 010300         05  RA-CD-D4      PIC 99.
  3297. 010400         05  PLU-CD-D4       PIC 99.
  3298. 010500     03  ALLOT-NUM-D4    PIC 9999.
  3299. 010600     03  PASTURE-NUM-D4  PIC 99.
  3300. 010700     03  SWAT-D4.
  3301. 010800         05  SWA-D4.
  3302. 010900             07  SWA-CD-D4      PIC X.
  3303. 011000             07  SWA-NUM-D4     PIC 999.
  3304. 011100         05  TRN-NUM-D4     PIC 99.
  3305. 011200 COPY  REC-KEY0 IN LIBRARY.
  3306. 011300 01  REC-KEY1.
  3307. 011400     05  SWAT-RK1            PIC X(20).
  3308. 011500     05  REC-KEY-RK1         PIC 9(1).
  3309. 011600     05  VEG-SUB-TYPE-RK1    PIC 9(4).
  3310. 011700     05  SWA-PCT-RK1         PIC 9(3).
  3311. 011800     05  CMPR-ID-FLAG-RK1     PIC X(1).
  3312. 011900     05  SSF-GRP-RK1         PIC X(14).
  3313. 012000     05  SSF-VAL-RAT-RK1 REDEFINES SSF-GRP-RK1
  3314. 012100             OCCURS 7 TIMES  PIC 9(2).
  3315. 012200     05  TYP-GC-HITS-GRP-RK1 PIC X(21).
  3316. 012300     05  TYP-GC-HITS-RK1 REDEFINES TYP-GC-HITS-GRP-RK1
  3317. 012400             OCCURS 7 TIMES  PIC 9(3).
  3318. 012500     05  FILLER              PIC X(38).
  3319. 012600*COPY  REC-KEY1 IN LIBRARY.
  3320. 012700 COPY  REC-KEY2 IN LIBRARY.
  3321. 012800 COPY  REC-KEY3 IN LIBRARY.
  3322. 012900 COPY  REC-K4V2 IN LIBRARY.
  3323. 013000 COPY  REC-KEY5 IN LIBRARY.
  3324. 013100 COPY  REC-KEY7 IN LIBRARY.
  3325. 013200 COPY  REC-KEY8 IN LIBRARY.
  3326. 013300 COPY  WDB01 IN LIBRARY.
  3327. 013400 COPY  WDB02 IN LIBRARY.
  3328. 013500 COPY  WDB03 IN LIBRARY.
  3329. 013600*COPY  WDB05 IN LIBRARY.
  3330. 013700 01  WDB-05.
  3331. 013800     05  REC-NUM-V21A-WDB         PIC 9(2).
  3332. 013900     05  LINE-NUM-V21A-WDB        PIC 9(4).
  3333. 014000     05  PLANT-TYP-V21A-WDB       PIC X(1).
  3334. 014100     05  PLANT-CD-V21A-WDB        PIC X(7).
  3335. 014200     05  AGE-CLS-PLANT-V21A-WDB   PIC X(1).
  3336. 014300     05  CLS-PLANT-AVAIL-V21A-WDB PIC X(1).
  3337. 014400     05  PLOT-SIZE-V21A-WDB       PIC 9(1).
  3338. 014500     05  PLOT-NUM-V21A-WDB        PIC 9(2).
  3339. 014600     05  FORM-CLS-PLANT-V21A-WDB  PIC 9(1).
  3340. 014700     05  PHNO-STG-V21A-WDB        PIC 9(1).
  3341. 014800     05  CLS-PLANT-UTIL-V21A-WDB  PIC 9(1).
  3342. 014900     05  AVG-HGT-PLANT-V21A-WDB   PIC 999V9.
  3343. 015000     05  CHARZD-NUM-V21A-WDB      PIC 9(3).
  3344. 015100     05  AVG-CROWN-DIA-V21A-WDB   PIC 99V9.
  3345. 015200     05  CHARZD-NOT-NUM-V21A-WDB  PIC 9(3).
  3346. 015300 COPY  WDB10-13 IN LIBRARY.
  3347. 015400 01  TYP-GC-HIT-TABLE.
  3348. 015500     03  TGH-TB        PIC 999   OCCURS 7 TIMES.
  3349. 015600 01  SPECIES-LIST-TABLE.
  3350. 015700     03  S-L-TAB.
  3351. 015800         05  S-L-GP    OCCURS 100.
  3352. 015900             07  SPEC-TYP-SL  PIC X.
  3353. 016000             07  SPEC-SL      PIC X(7).
  3354. 016100     03  S-L-TAB-RD REDEFINES S-L-TAB.
  3355. 016200         05  S-L-TB     PIC X(80)   OCCURS 10 TIMES.
  3356. 016300 01  PLOT-TABLE.
  3357. 016400     03  PLOT-TAB    PIC 9   OCCURS 40 TIMES.
  3358. 016500 01  PLOT-SUB        PIC 99  VALUE ZERO.
  3359. 016600 01  PLOT-CNT        PIC 99  VALUE ZERO.
  3360. 016700 01  CNT-HLD.
  3361. 016800     03  CNT-1  PIC 9(8)  VALUE ZERO.
  3362. 016900     03  CNT-2  PIC 9(8)  VALUE ZERO.
  3363. 017000     03  CNT-3  PIC 9(8)  VALUE ZERO.
  3364. 017100     03  CNT-4  PIC 9(8)  VALUE ZERO.
  3365. 017200     03  CNT-5  PIC 9(8)  VALUE ZERO.
  3366. 017300     03  CNT-6  PIC 9(8)  VALUE 1.
  3367. 017400 01  DISP-REC.
  3368. 017500     03  DISP-1    PIC ZZ,ZZZ,ZZZ.
  3369. 017600     03  FILLER  PIC X(12) VALUE " RECS IN    ".
  3370. 017700     03  DISP-2    PIC ZZ,ZZZ,ZZZ.
  3371. 017800     03  FILLER  PIC X(12) VALUE " TRANSECTS  ".
  3372. 017900     03  DISP-3    PIC ZZ,ZZZ,ZZZ.
  3373. 018000     03  FILLER  PIC X(12) VALUE " RECS OUT D3".
  3374. 018100     03  DISP-4    PIC ZZ,ZZZ,ZZZ.
  3375. 018200     03  FILLER  PIC X(12) VALUE " RECS OUT D1".
  3376. 018300     03  DISP-5    PIC ZZ,ZZZ,ZZZ.
  3377. 018400     03  FILLER  PIC X(12) VALUE " RECS OUT D2".
  3378. 018500     03  DISP-6    PIC ZZ,ZZZ,ZZZ.
  3379. 018600     03  FILLER  PIC X(12) VALUE " SWAT BREAK ".
  3380. 018700 01  RMK-REC.
  3381. 018800     03  RMK-P   PIC X(8)  VALUE SPACE.
  3382. 018900     03  DBS-P    PIC X(8).
  3383. 019000     03  SWAT-P   PIC X(21).
  3384. 019100 01  P-SPACE     PIC X(132)  VALUE SPACE.
  3385. 019200 PROCEDURE DIVISION.
  3386. 019300 010-HOUSEKEEPING.
  3387. 019400     OPEN OUTPUT FILE-D1 FILE-D3 FILE-P1 FILE-D2.
  3388. 019500     OPEN INPUT FILE-D4.
  3389. 019600     MOVE SPACE TO RMK-REC CNTL-HLD REC-KEY9.
  3390. 019700     INITIALIZE WDB-01 WDB-02 WDB-03
  3391. 019800         PLOT-TABLE
  3392. 019900         WDB-05 WDB-10-13
  3393. 020000         TYP-GC-HIT-TABLE SPECIES-LIST-TABLE.
  3394. 020100 300-FIND-SWAT-CONN.
  3395. 020200     INITIALIZE TAB-KEY-HLD TYP-GC-HIT-TABLE
  3396. 020300     SLT-SUB SPECIES-LIST-TABLE.
  3397. 020400 301-READ.
  3398. 020500     READ FILE-D4 INTO V11Z AT END
  3399. 020600        PERFORM 900-BUILD-REC-1 THRU 930-EXIT
  3400. 020700         GO TO 940-DISPLAY.
  3401. 020800     ADD 1 TO CNT-1.
  3402. 020900     MOVE ADST-CD-V11Z TO ADST-CD-D4.
  3403. 021000     MOVE DIST-CD-V11Z TO DIST-CD-D4.
  3404. 021100     MOVE PLU-CD-V11Z TO PLU-CD-D4.
  3405. 021200     MOVE RA-CD TO RA-CD-D4.
  3406. 021300     MOVE ALLOT-NUM-V11Z TO ALLOT-NUM-D4.
  3407. 021400     IF PAST-NUM-D4-IN NOT = SPACE
  3408. 021500         MOVE PAST-NUM-D4-IN TO PASTURE-NUM-D4
  3409. 021600         ELSE
  3410. 021700         MOVE ZERO TO PASTURE-NUM-D4.
  3411. 021800     MOVE SWA-V11Z TO SWA-D4.
  3412. 021900     MOVE TRN-NUM-V11Z TO TRN-NUM-D4.
  3413. 022000     IF CNTL-HLD = SPACE
  3414. 022100         MOVE CNTL-D4 TO CNTL-HLD.
  3415. 022200     IF CNTL-HLD NOT = CNTL-D4
  3416. 022300         ADD 1 TO CNT-6
  3417. 022400         MOVE ZERO TO FIRST-RK9-SW
  3418. 022500        PERFORM 900-BUILD-REC-1 THRU 930-EXIT
  3419. 022600        MOVE CNTL-D4 TO CNTL-HLD.
  3420. 022700 301-PROCESS.
  3421. 022800     IF (REC-TYP-D4 = "V11A") MOVE 1 TO REC-TYP-IN.
  3422. 022900     IF (REC-TYP-D4 = "V12A") MOVE 2 TO REC-TYP-IN.
  3423. 023000     IF (REC-TYP-D4 = "V13A") MOVE 3 TO REC-TYP-IN.
  3424. 023100     IF (REC-TYP-D4 = "V14A") MOVE 4 TO REC-TYP-IN.
  3425. 023200     IF (REC-TYP-D4 = "V21A") MOVE 5 TO REC-TYP-IN.
  3426. 023300     IF (REC-TYP-D4 = "V31B") MOVE 7 TO REC-TYP-IN.
  3427. 023400     IF (REC-TYP-D4 = "V32B") MOVE 7 TO REC-TYP-IN.
  3428. 023500     IF (REC-TYP-D4 = "V33B") MOVE 7 TO REC-TYP-IN.
  3429. 023600     IF (REC-TYP-D4 = "V34B") MOVE 7 TO REC-TYP-IN.
  3430. 023700     IF REC-TYP-IN NOT = 1
  3431. 023800         GO TO 420-CK-REC.
  3432. 023900 302-BUILD-V11.
  3433. 024000     ADD 1 TO CNT-2.
  3434. 024100     MOVE SPACE TO WDB-01.
  3435. 024200     MOVE ADST-CD-V11Z TO ADST-SI-WDB.
  3436. 024300     MOVE DIST-CD-V11Z TO DIST-SI-WDB.
  3437. 024400     MOVE PLU-CD-V11Z TO PLU-SI-WDB.
  3438. 024500     MOVE RA-CD TO RA-SI-WDB.
  3439. 024600     MOVE SWA-V11Z TO SWA-SI-WDB.
  3440. 024700     MOVE TRN-NUM-V11Z TO TRN-NUM-SI-WDB.
  3441. 024800     MOVE ALLOT-NUM-SH TO ALLOT-NUM-WDB.
  3442. 024900     MOVE PASTURE-NUM-SH TO PASTURE-NUM-WDB.
  3443. 025000     MOVE SPACE TO SWAT-BRWD-WDB.
  3444. 025100     IF (REC-TYP-IN = 1) AND
  3445. 025200         (ADST-CD-V11AZ NOT = SPACE)
  3446. 025300         MOVE "C" TO CMPR-ID-FLAG-WDB
  3447. 025400         ELSE MOVE "S" TO CMPR-ID-FLAG-WDB.
  3448. 025500 302-GO-TO.
  3449. 025600     GO TO 301-READ.
  3450. 025700 420-CK-REC.
  3451. 025800     IF ADST-SI-WDB = SPACE
  3452. 025900         PERFORM 302-BUILD-V11.
  3453. 026000     IF REC-TYP-IN = 3 GO TO 423-REC-V13.
  3454. 026100     IF REC-TYP-IN = 4 GO TO 424-REC-V14.
  3455. 026200     IF REC-TYP-IN = 5 GO TO 425-REC-V21.
  3456. 026300     IF REC-TYP-IN = 7 GO TO 427-REC-V3B.
  3457. 026400     MOVE SPACE TO WDB-02.
  3458. 026500         MOVE LINE-NUM-V11Z TO LINE-NUM-V12A-WDB
  3459. 026600         MOVE 02 TO REC-NUM-V12A-WDB
  3460. 026700         MOVE GRP-V12AZ (1) TO GRP-2-V12A-WDB (1)
  3461. 026800         MOVE GRP-V12AZ (2) TO GRP-2-V12A-WDB (2)
  3462. 026900         MOVE GRP-V12AZ (3) TO GRP-2-V12A-WDB (3)
  3463. 027000         MOVE GRP-V12AZ (4) TO GRP-2-V12A-WDB (4)
  3464. 027100         MOVE TYP-GC-CD-V12AZ TO TYP-GC-CD-V12A-WDB
  3465. 027200         MOVE TYP-GC-HITS-V12AZ TO TYP-GC-HITS-V12A-WDB
  3466. 027300         PERFORM 750-PROC-REC-02 THRU 770-EXIT.
  3467. 027400     GO TO 301-READ.
  3468. 027500 423-REC-V13.
  3469. 027600     MOVE SPACE TO WDB-03.
  3470. 027700         MOVE LINE-NUM-V11Z TO LINE-NUM-V13A-WDB
  3471. 027800         MOVE 03 TO REC-NUM-V13A-WDB
  3472. 027900         MOVE TYP-GC-HITS-V13AZ (1) TO TYP-GC-HITS-V13A-WDB (1)
  3473. 028000         MOVE TYP-GC-HITS-V13AZ (2) TO TYP-GC-HITS-V13A-WDB (2)
  3474. 028100         MOVE PLANT-CD-BL-V13AZ (1) TO PLANT-CD-BL-V13A-WDB (1)
  3475. 028200         MOVE PLANT-CD-BL-V13AZ (2) TO PLANT-CD-BL-V13A-WDB (2)
  3476. 028300        MOVE PLANT-CD-C1-V13AZ (1) TO PLANT-CD-V13A-WDB (1 1)
  3477. 028400        MOVE PLANT-CD-C1-V13AZ (2) TO PLANT-CD-V13A-WDB (2 1)
  3478. 028500        MOVE PLANT-CD-C2-V13AZ (1) TO PLANT-CD-V13A-WDB (1 2)
  3479. 028600        MOVE PLANT-CD-C2-V13AZ (2) TO PLANT-CD-V13A-WDB (2 2)
  3480. 028700        MOVE PLANT-CD-C3-V13AZ (1) TO PLANT-CD-V13A-WDB (1 3)
  3481. 028800        MOVE PLANT-CD-C3-V13AZ (2) TO PLANT-CD-V13A-WDB (2 3)
  3482. 028900     MOVE LEV-TRN-HIT-BL-V13AZ (1) TO LEV-TRN-HIT-BL-V13A-WDB (1)
  3483. 029000     MOVE LEV-TRN-HIT-BL-V13AZ (2) TO LEV-TRN-HIT-BL-V13A-WDB (2)
  3484. 029100     MOVE LEV-TRN-HIT-C1-V13AZ (1) TO LEV-TRN-HIT-V13A-WDB (1 1)
  3485. 029200     MOVE LEV-TRN-HIT-C1-V13AZ (2) TO LEV-TRN-HIT-V13A-WDB (2 1)
  3486. 029300     MOVE LEV-TRN-HIT-C2-V13AZ (1) TO LEV-TRN-HIT-V13A-WDB (1 2)
  3487. 029400     MOVE LEV-TRN-HIT-C2-V13AZ (2) TO LEV-TRN-HIT-V13A-WDB (2 2)
  3488. 029500     MOVE LEV-TRN-HIT-C3-V13AZ (1) TO LEV-TRN-HIT-V13A-WDB (1 3)
  3489. 029600     MOVE LEV-TRN-HIT-C3-V13AZ (2) TO LEV-TRN-HIT-V13A-WDB (2 3)
  3490. 029700         PERFORM 500-BUILD-REC-3 THRU 520-EXIT.
  3491. 029800     GO TO 301-READ.
  3492. 029900 424-REC-V14.
  3493. 030000     MOVE SSF-VAL-RAT-V14AZ (1)  TO SSF-VAL-RAT-WDB (1).
  3494. 030100     MOVE SSF-VAL-RAT-V14AZ (2) TO SSF-VAL-RAT-WDB (2).
  3495. 030200     MOVE SSF-VAL-RAT-V14AZ (3) TO SSF-VAL-RAT-WDB (3).
  3496. 030300     MOVE SSF-VAL-RAT-V14AZ (4)  TO SSF-VAL-RAT-WDB (4).
  3497. 030400     MOVE SSF-VAL-RAT-V14AZ (5) TO SSF-VAL-RAT-WDB (5).
  3498. 030500     MOVE SSF-VAL-RAT-V14AZ (6) TO SSF-VAL-RAT-WDB (6).
  3499. 030600     MOVE SSF-VAL-RAT-V14AZ (7) TO SSF-VAL-RAT-WDB (7).
  3500. 030700     GO TO 301-READ.
  3501. 030800 425-REC-V21.
  3502. 030900     MOVE SPACE TO WDB-05.
  3503. 031000     MOVE LINE-NUM-V11Z TO LINE-NUM-V21A-WDB.
  3504. 031100     MOVE 05 TO REC-NUM-V13A-WDB.
  3505. 031200     MOVE PLOT-SIZE-V21AZ TO PLOT-SIZE-V21A-WDB.
  3506. 031300     MOVE PLOT-NUM-V21AZ TO PLOT-NUM-V21A-WDB.
  3507. 031400     MOVE CHARZD-NUM-V21AZ TO CHARZD-NUM-V21A-WDB.
  3508. 031500     MOVE PLANT-CD-V21AZ TO PLANT-CD-V21A-WDB.
  3509. 031600     IF PLANT-CD-V21AZ = "BARREN "
  3510. 031700         PERFORM 600-BUILD-RECS-0-6-7 THRU 600-EXIT
  3511. 031800         GO TO 301-READ.
  3512. 031900     MOVE PLANT-TYP-V21AZ TO PLANT-TYP-V21A-WDB.
  3513. 032000     MOVE AGE-CLS-PLANT-V21AZ TO AGE-CLS-PLANT-V21A-WDB.
  3514. 032100     MOVE CLS-PLANT-AVAIL-V21AZ TO CLS-PLANT-AVAIL-V21A-WDB.
  3515. 032200     MOVE FORM-CLS-PLANT-V21AZ TO FORM-CLS-PLANT-V21A-WDB.
  3516. 032300     MOVE PHNO-STG-V21AZ TO PHNO-STG-V21A-WDB.
  3517. 032400     MOVE CLS-PLANT-UTIL-V21AZ TO CLS-PLANT-UTIL-V21A-WDB.
  3518. 032500     MOVE AVG-HGT-PLANT-V21AZ TO AVG-HGT-PLANT-V21A-WDB.
  3519. 032600     MOVE AVG-CRN-DIA-V21AZ TO AVG-CROWN-DIA-V21A-WDB.
  3520. 032700     MOVE CHARZD-NOT-NUM-V21AZ TO CHARZD-NOT-NUM-V21A-WDB.
  3521. 032800     PERFORM 600-BUILD-RECS-0-6-7 THRU 600-EXIT.
  3522. 032900     GO TO 301-READ.
  3523. 033000 427-REC-V3B.
  3524. 033100     IF PLANT-CD-V3XBZ = "BARREN "
  3525. 033200         INITIALIZE WDB-10-13 ELSE
  3526. 033300         MOVE SPACE TO WDB-10-13.
  3527. 033400     MOVE LINE-NUM-V11Z TO LINE-NUM-V3XB-WDB.
  3528. 033500     IF (REC-TYP-D4 = "V31B") MOVE 10 TO REC-NUM-V3XB-WDB.
  3529. 033600     IF (REC-TYP-D4 = "V32B") MOVE 11 TO REC-NUM-V3XB-WDB.
  3530. 033700     IF (REC-TYP-D4 = "V33B") MOVE 12 TO REC-NUM-V3XB-WDB.
  3531. 033800     IF (REC-TYP-D4 = "V34B") MOVE 13 TO REC-NUM-V3XB-WDB.
  3532. 033900*    MOVE 10 TO REC-NUM-V3XB-WDB.
  3533. 034000     MOVE PLANT-CD-V3XBZ TO PLANT-CD-V3XB-WDB.
  3534. 034100     MOVE PLOT-TOT-NUM-V3XBZ TO PLOT-TOT-NUM-V3XB-WDB.
  3535. 034200     MOVE PLOT-SIZ-EST-V3XBZ TO PLOT-SIZ-EST-V3XB-WDB.
  3536. 034300     IF PLANT-CD-V3XB-WDB = "BARREN "
  3537. 034400         PERFORM 700-BUILD-REC-5 THRU 720-EXIT
  3538. 034500         GO TO 301-READ.
  3539. 034600     MOVE PLANT-TYP-V3XBZ TO PLANT-TYP-V3XB-WDB.
  3540. 034700     MOVE HGT-CLS-CD-V3XBZ TO HGT-CLS-CD-V3XB-WDB.
  3541. 034800     MOVE PHNO-STG-V3XBZ (1) TO PHNO-STG-V3XB-WDB (1).
  3542. 034900     MOVE PHNO-STG-V3XBZ (2) TO PHNO-STG-V3XB-WDB (2)
  3543. 035000     MOVE PHNO-STG-V3XBZ (3) TO PHNO-STG-V3XB-WDB (3)
  3544. 035100     MOVE PHNO-STG-V3XBZ (4) TO PHNO-STG-V3XB-WDB (4)
  3545. 035200     MOVE PHNO-STG-V3XBZ (5) TO PHNO-STG-V3XB-WDB (5)
  3546. 035300     MOVE PHNO-STG-V3XBZ (6) TO PHNO-STG-V3XB-WDB (6)
  3547. 035400     MOVE PHNO-STG-V3XBZ (7) TO PHNO-STG-V3XB-WDB (7)
  3548. 035500     MOVE PHNO-STG-V3XBZ (8) TO PHNO-STG-V3XB-WDB (8)
  3549. 035600     MOVE PHNO-STG-V3XBZ (9) TO PHNO-STG-V3XB-WDB (9)
  3550. 035700     MOVE PHNO-STG-V3XBZ (10) TO PHNO-STG-V3XB-WDB (10).
  3551. 035800     MOVE CLS-PLANT-UTIL-V3XBZ (1) TO CLS-PLANT-UTIL-V3XB-WDB (1)
  3552. 035900     MOVE CLS-PLANT-UTIL-V3XBZ (2) TO CLS-PLANT-UTIL-V3XB-WDB (2)
  3553. 036000     MOVE CLS-PLANT-UTIL-V3XBZ (3) TO CLS-PLANT-UTIL-V3XB-WDB (3)
  3554. 036100     MOVE CLS-PLANT-UTIL-V3XBZ (4) TO CLS-PLANT-UTIL-V3XB-WDB (4)
  3555. 036200     MOVE CLS-PLANT-UTIL-V3XBZ (5) TO CLS-PLANT-UTIL-V3XB-WDB (5)
  3556. 036300     MOVE CLS-PLANT-UTIL-V3XBZ (6) TO CLS-PLANT-UTIL-V3XB-WDB (6)
  3557. 036400     MOVE CLS-PLANT-UTIL-V3XBZ (7) TO CLS-PLANT-UTIL-V3XB-WDB (7)
  3558. 036500     MOVE CLS-PLANT-UTIL-V3XBZ (8) TO CLS-PLANT-UTIL-V3XB-WDB (8)
  3559. 036600     MOVE CLS-PLANT-UTIL-V3XBZ (9) TO CLS-PLANT-UTIL-V3XB-WDB (9)
  3560. 036700     MOVE CLS-PLANT-UTIL-V3XBZ (10) TO
  3561. 036800         CLS-PLANT-UTIL-V3XB-WDB (10)
  3562. 036900     MOVE HRBG-PROD-WGT-V3XBZ (1) TO HRBG-PROD-WGT-V3XB-WDB (1)
  3563. 037000     MOVE HRBG-PROD-WGT-V3XBZ (2) TO HRBG-PROD-WGT-V3XB-WDB (2)
  3564. 037100     MOVE HRBG-PROD-WGT-V3XBZ (3) TO HRBG-PROD-WGT-V3XB-WDB (3)
  3565. 037200     MOVE HRBG-PROD-WGT-V3XBZ (4) TO HRBG-PROD-WGT-V3XB-WDB (4)
  3566. 037300     MOVE HRBG-PROD-WGT-V3XBZ (5) TO HRBG-PROD-WGT-V3XB-WDB (5)
  3567. 037400     MOVE HRBG-PROD-WGT-V3XBZ (6) TO HRBG-PROD-WGT-V3XB-WDB (6)
  3568. 037500     MOVE HRBG-PROD-WGT-V3XBZ (7) TO HRBG-PROD-WGT-V3XB-WDB (7)
  3569. 037600     MOVE HRBG-PROD-WGT-V3XBZ (8) TO HRBG-PROD-WGT-V3XB-WDB (8)
  3570. 037700     MOVE HRBG-PROD-WGT-V3XBZ (9) TO HRBG-PROD-WGT-V3XB-WDB (9)
  3571. 037800     MOVE HRBG-PROD-WGT-V3XBZ (10) TO HRBG-PROD-WGT-V3XB-WDB (10)
  3572. 037900     MOVE CLS-PLANT-AVAIL-V3XBZ (1) TO
  3573. 038000         CLS-PLANT-AVAIL-V3XB-WDB (1)
  3574. 038100     MOVE CLS-PLANT-AVAIL-V3XBZ (2) TO
  3575. 038200         CLS-PLANT-AVAIL-V3XB-WDB (2)
  3576. 038300     MOVE CLS-PLANT-AVAIL-V3XBZ (3) TO
  3577. 038400         CLS-PLANT-AVAIL-V3XB-WDB (3)
  3578. 038500     MOVE CLS-PLANT-AVAIL-V3XBZ (4) TO
  3579. 038600         CLS-PLANT-AVAIL-V3XB-WDB (4)
  3580. 038700     MOVE CLS-PLANT-AVAIL-V3XBZ (5) TO
  3581. 038800         CLS-PLANT-AVAIL-V3XB-WDB (5)
  3582. 038900     MOVE CLS-PLANT-AVAIL-V3XBZ (6) TO
  3583. 039000         CLS-PLANT-AVAIL-V3XB-WDB (6)
  3584. 039100     MOVE CLS-PLANT-AVAIL-V3XBZ (7) TO
  3585. 039200         CLS-PLANT-AVAIL-V3XB-WDB (7)
  3586. 039300     MOVE CLS-PLANT-AVAIL-V3XBZ (8) TO
  3587. 039400         CLS-PLANT-AVAIL-V3XB-WDB (8)
  3588. 039500     MOVE CLS-PLANT-AVAIL-V3XBZ (9) TO
  3589. 039600         CLS-PLANT-AVAIL-V3XB-WDB (9)
  3590. 039700     MOVE CLS-PLANT-AVAIL-V3XBZ (10) TO
  3591. 039800         CLS-PLANT-AVAIL-V3XB-WDB (10).
  3592. 039900     PERFORM 700-BUILD-REC-5 THRU 720-EXIT.
  3593. 040000     GO TO 301-READ.
  3594. 040100 500-BUILD-REC-3.
  3595. 040200     MOVE SPACE TO REC-KEY3.
  3596. 040300     MOVE ZERO TO SUB-03.
  3597. 040400     MOVE CNTL-HLD TO SWAT-RK3.
  3598. 040500     MOVE 3 TO REC-KEY-RK3.
  3599. 040600 510-LP-TB.
  3600. 040700     IF SUB-03 = 02
  3601. 040800         GO TO 520-EXIT.
  3602. 040900     ADD 1 TO SUB-03.
  3603. 041000     IF PLANT-CD-BL-V13A-WDB (SUB-03) NOT = SPACE
  3604. 041100         MOVE PLANT-CD-BL-V13A-WDB (SUB-03) TO
  3605. 041200             PLANT-CD-BL-RK3
  3606. 041300         MOVE LEV-TRN-HIT-BL-V13A-WDB (SUB-03) TO
  3607. 041400             LEV-TRN-HIT-BL-RK3
  3608. 041500         MOVE PLANT-GRP-1-V13A-WDB (SUB-03) TO GRP-1-RK3
  3609. 041600         MOVE TYP-GC-HITS-V13A-WDB (SUB-03) TO TYP-GC-HITS-RK3
  3610. 041700         WRITE FDR-D1 FROM REC-KEY3
  3611. 041800         ADD 1 TO CNT-4
  3612. 041900         GO TO 510-LP-TB.
  3613. 042000 520-EXIT.
  3614. 042100     EXIT.
  3615. 042200 600-BUILD-RECS-0-6-7.
  3616. 042300     MOVE SPACE TO REC-KEY0.
  3617. 042400     IF PLANT-CD-V21A-WDB = "BARREN "
  3618. 042500         INITIALIZE REC-KEY0.
  3619. 042600     MOVE CNTL-HLD TO SWAT-RK0.
  3620. 042700     MOVE 0 TO REC-KEY-RK0.
  3621. 042800     MOVE "V2" TO REC-TYP-RK0.
  3622. 042900     MOVE 1 TO FMT-NUM-RK0.
  3623. 043000     MOVE "A" TO FMT-CD-RK0.
  3624. 043100     ADD 1 TO TAB-KEY-HLD.
  3625. 043200     MOVE TAB-KEY-HLD TO TAB-KEY-0.
  3626. 043300     MOVE PLANT-CD-V21A-WDB TO SPECIES-KEY-0 PLANT-CD-RK0.
  3627. 043400     MOVE CHARZD-NUM-V21A-WDB TO CHARZD-NUM-RK0.
  3628. 043500     MOVE PLOT-SIZE-V21A-WDB TO PLOT-SIZE-0.
  3629. 043600     MOVE PLOT-NUM-V21A-WDB TO PLOT-NUM-RK0 PLOT-NUM-KEY-0.
  3630. 043700     IF PLANT-CD-V21A-WDB = "BARREN "
  3631. 043800         GO TO 600-WR-REC-KEY-0.
  3632. 043900     MOVE AGE-CLS-PLANT-V21A-WDB TO AGE-CLS-PLANT-RK0.
  3633. 044000     MOVE FORM-CLS-PLANT-V21A-WDB TO FORM-CLS-PLANT-RK0.
  3634. 044100     MOVE PHNO-STG-V21A-WDB TO PHNO-STG-RK0.
  3635. 044200     MOVE CLS-PLANT-AVAIL-V21A-WDB TO CLS-PLANT-AVAIL-RK0.
  3636. 044300     MOVE CLS-PLANT-UTIL-V21A-WDB TO CLS-PLANT-UTIL-RK0.
  3637. 044400     MOVE AVG-HGT-PLANT-V21A-WDB TO AVG-HGT-PLANT-RK0.
  3638. 044500     MOVE AVG-CROWN-DIA-V21A-WDB TO AVG-CROWN-DIA-RK0.
  3639. 044600     MOVE CHARZD-NOT-NUM-V21A-WDB TO CHARZD-NOT-NUM-RK0.
  3640. 044700     MOVE PLANT-TYP-V21A-WDB TO PLANT-TYP-RK0.
  3641. 044800 600-WR-REC-KEY-0.
  3642. 044900     IF ((PLOT-NUM-KEY-0 > ZERO) AND
  3643. 045000      (PLANT-CD-V21A-WDB NOT = "BARREN "))  OR
  3644. 045100      ((PLOT-NUM-KEY-0 > ZERO) AND
  3645. 045200      (PLANT-CD-V21A-WDB = "BARREN ") AND
  3646. 045300       (CHARZD-NUM-V21A-WDB > ZERO))
  3647. 045400         MOVE 1 TO PLOT-TAB (PLOT-NUM-KEY-0).
  3648. 045500     IF PLANT-CD-V21A-WDB = "BARREN "
  3649. 045600         GO TO 600-EXIT.
  3650. 045700     WRITE FDR-D3 FROM REC-KEY0.
  3651. 045800     ADD 1 TO CNT-3.
  3652. 045900     MOVE 6 TO REC-KEY-RK0.
  3653. 046000     MOVE FORM-CLS-PLANT-RK0 TO FORM-CLS-KEY-6.
  3654. 046100     MOVE PLOT-NUM-RK0 TO PLOT-NUM-KEY-6.
  3655. 046200     WRITE FDR-D3 FROM REC-KEY0.
  3656. 046300     ADD 1 TO CNT-3.
  3657. 046400     MOVE 7 TO REC-KEY-RK0.
  3658. 046500     MOVE AGE-CLS-PLANT-RK0 TO AGE-CLS-KEY-7.
  3659. 046600     WRITE FDR-D3 FROM REC-KEY0.
  3660. 046700     ADD 1 TO CNT-3.
  3661. 046800 600-EXIT.
  3662. 046900     EXIT.
  3663. 047000 700-BUILD-REC-5.
  3664. 047100     IF PLANT-CD-V3XB-WDB = "BARREN "
  3665. 047200         INITIALIZE REC-KEY5 ELSE
  3666. 047300         MOVE SPACE TO REC-KEY5.
  3667. 047400     IF FIRST-RK9-SW = ZERO
  3668. 047500*        AND (PLANT-CD-V3XB-WDB NOT = "BARREN ")
  3669. 047600         MOVE 1 TO FIRST-RK9-SW
  3670. 047700         MOVE SPACE TO REC-KEY9
  3671. 047800         MOVE SDRP-SH TO SDRP-RK9
  3672. 047900         MOVE 9 TO REC-KEY-RK9
  3673. 048000         MOVE SWAT-SH TO SWAT-RK9
  3674. 048100         MOVE PLOT-TOT-NUM-V3XB-WDB TO PLOTS-RK9
  3675. 048200         ADD 1 TO CNT-5
  3676. 048300         WRITE FDR-D2 FROM REC-KEY9.
  3677. 048400     MOVE CNTL-HLD TO SWAT-RK5.
  3678. 048500     MOVE 5 TO REC-KEY-RK5.
  3679. 048600     MOVE "V3" TO REC-TYP-RK5.
  3680. 048700     MOVE "B" TO FMT-CD-RK5.
  3681. 048800     MOVE PLANT-CD-V3XB-WDB TO PLANT-CD-RK5 SPECIES-KEY-RK5.
  3682. 048900     MOVE PLOT-TOT-NUM-V3XB-WDB TO PLOT-TOT-NUM-RK5.
  3683. 049000     MOVE PLOT-SIZ-EST-V3XB-WDB TO PLOT-SIZ-EST-RK5.
  3684. 049100     IF REC-NUM-V3XB-WDB = 10 MOVE 1 TO FMT-NUM-RK5.
  3685. 049200     IF REC-NUM-V3XB-WDB = 11 MOVE 2 TO FMT-NUM-RK5.
  3686. 049300     IF REC-NUM-V3XB-WDB = 12 MOVE 3 TO FMT-NUM-RK5.
  3687. 049400     IF REC-NUM-V3XB-WDB = 13 MOVE 4 TO FMT-NUM-RK5.
  3688. 049500     IF PLANT-CD-V3XB-WDB = "BARREN "
  3689. 049600         MOVE "ZZBAREN" TO PLANT-CD-RK5 SPECIES-KEY-RK5
  3690. 049700         WRITE FDR-D3 FROM REC-KEY5
  3691. 049800         ADD 1 TO CNT-3
  3692. 049900         GO TO 720-EXIT.
  3693. 050000     MOVE HGT-CLS-CD-V3XB-WDB TO HGT-CLS-CD-RK5.
  3694. 050100     MOVE PLANT-TYP-V3XB-WDB TO PLANT-TYP-RK5.
  3695. 050200     MOVE ZERO TO SUB-5.
  3696. 050300 710-LP-PLOT.
  3697. 050400     ADD 1 TO SUB-5.
  3698. 050500     IF SUB-5 > 10
  3699. 050600         WRITE FDR-D3 FROM REC-KEY5
  3700. 050700         ADD 1 TO CNT-3
  3701. 050800         GO TO 720-EXIT.
  3702. 050900     MOVE GRP-2-V3XB-WDB (SUB-5) TO GRP-3-RK5 (SUB-5).
  3703. 051000     MOVE CLS-PLANT-AVAIL-V3XB-WDB (SUB-5) TO
  3704. 051100         CLS-PLANT-AVAIL-RK5 (SUB-5).
  3705. 051200     GO TO 710-LP-PLOT.
  3706. 051300 720-EXIT.
  3707. 051400     EXIT.
  3708. 051500 750-PROC-REC-02.
  3709. 051600     MOVE ZERO TO SUB-02.
  3710. 051700     MOVE 0 TO SUB-GC.
  3711. 051800     IF (TYP-GC-HITS-V12A-WDB) > ZERO
  3712. 051900         IF TYP-GC-CD-V12A-WDB = "B" MOVE 1 TO SUB-GC ELSE
  3713. 052000         IF TYP-GC-CD-V12A-WDB = "P" MOVE 2 TO SUB-GC ELSE
  3714. 052100         IF TYP-GC-CD-V12A-WDB = "N" MOVE 3 TO SUB-GC ELSE
  3715. 052200         IF TYP-GC-CD-V12A-WDB = "G" MOVE 4 TO SUB-GC ELSE
  3716. 052300         IF TYP-GC-CD-V12A-WDB = "C" MOVE 5 TO SUB-GC ELSE
  3717. 052400         IF TYP-GC-CD-V12A-WDB = "S" MOVE 6 TO SUB-GC ELSE
  3718. 052500         IF TYP-GC-CD-V12A-WDB = "R" MOVE 7 TO SUB-GC.
  3719. 052600     IF SUB-GC > ZERO
  3720. 052700         MOVE TYP-GC-HITS-V12A-WDB TO TGH-TB (SUB-GC).
  3721. 052800 760-LP-TB.
  3722. 052900     ADD 1 TO SUB-02.
  3723. 053000     IF SUB-02 > 4
  3724. 053100          GO TO 770-EXIT.
  3725. 053200     IF PLANT-CD-V12A-WDB (SUB-02) = SPACE
  3726. 053300         GO TO 760-LP-TB.
  3727. 053400     ADD 1 TO SLT-SUB.
  3728. 053500     MOVE PLANT-TYP-V12A-WDB (SUB-02) TO SPEC-TYP-SL (SLT-SUB).
  3729. 053600     MOVE PLANT-CD-V12A-WDB (SUB-02) TO SPEC-SL (SLT-SUB).
  3730. 053700     GO TO 760-LP-TB.
  3731. 053800 770-EXIT.
  3732. 053900     EXIT.
  3733. 054000 800-EXIT.
  3734. 054100     EXIT.
  3735. 054200 900-BUILD-REC-1.
  3736. 054300     MOVE SPACE TO REC-KEY1.
  3737. 054400     MOVE CNTL-HLD TO SWAT-RK1.
  3738. 054500     MOVE 1 TO REC-KEY-RK1.
  3739. 054600     MOVE ZERO TO VEG-SUB-TYPE-RK1 SWA-PCT-RK1.
  3740. 054700     MOVE CMPR-ID-FLAG-WDB TO CMPR-ID-FLAG-RK1.
  3741. 054800     MOVE TYP-GC-HIT-TABLE TO TYP-GC-HITS-GRP-RK1.
  3742. 054900     INITIALIZE TYP-GC-HIT-TABLE.
  3743. 055000     MOVE SSF-GRP-WDB TO SSF-GRP-RK1.
  3744. 055100     WRITE FDR-D1 FROM REC-KEY1.
  3745. 055200     ADD 1 TO CNT-4.
  3746. 055300     MOVE SPACE TO WDB-01.
  3747. 055400*    GO TO 925-PLOT-CNT.
  3748. 055500 910-BUILD-REC-2.
  3749. 055600     MOVE ZERO TO SLT-SUB.
  3750. 055700 920-LP-TB.
  3751. 055800     IF SLT-SUB = 10
  3752. 055900         INITIALIZE SPECIES-LIST-TABLE
  3753. 056000         GO TO 925-PLOT-CNT.
  3754. 056100     MOVE SPACE TO REC-KEY2.
  3755. 056200     MOVE CNTL-HLD TO SWAT-RK2.
  3756. 056300     MOVE 2 TO REC-KEY-RK2.
  3757. 056400     ADD 1 TO SLT-SUB.
  3758. 056500     IF S-L-TB (SLT-SUB)  = SPACE
  3759. 056600         GO TO 920-LP-TB.
  3760. 056700     MOVE S-L-TB (SLT-SUB) TO GRP-1-RK2
  3761. 056800     WRITE FDR-D1 FROM REC-KEY2
  3762. 056900     ADD 1 TO CNT-4.
  3763. 057000     GO TO 920-LP-TB.
  3764. 057100 925-PLOT-CNT.
  3765. 057200     MOVE SPACE TO SPECIES-KEY-0.
  3766. 057300     MOVE 0 TO REC-KEY-RK0.
  3767. 057400     MOVE ZERO TO PLOT-SUB, PLOT-CNT.
  3768. 057500 925-LP.
  3769. 057600     ADD 1 TO PLOT-SUB.
  3770. 057700     IF PLOT-SUB > 40
  3771. 057800         MOVE PLOT-CNT TO PLOT-NUM-KEY-0
  3772. 057900         MOVE SPACE TO PLANT-CD-RK0
  3773. 058000         WRITE FDR-D3 FROM REC-KEY0
  3774. 058100         ADD 1 TO CNT-3
  3775. 058200         INITIALIZE PLOT-TABLE
  3776. 058300         PLOT-SUB PLOT-CNT
  3777. 058400         GO TO 930-EXIT.
  3778. 058500     IF PLOT-TAB (PLOT-SUB) > ZERO
  3779. 058600         ADD 1 TO PLOT-CNT.
  3780. 058700     GO TO 925-LP.
  3781. 058800 930-EXIT.
  3782. 058900     EXIT.
  3783. 059000 940-DISPLAY.
  3784. 059100     MOVE CNT-1 TO DISP-1.
  3785. 059200     MOVE CNT-2 TO DISP-2.
  3786. 059300     MOVE CNT-3 TO DISP-3.
  3787. 059400     MOVE CNT-4 TO DISP-4.
  3788. 059500     MOVE CNT-5 TO DISP-5.
  3789. 059600     MOVE CNT-6 TO DISP-6.
  3790. 059700     DISPLAY DISP-REC.
  3791. 059800     GO TO 990-END.
  3792. 059900 950-EXIT.
  3793. 060000     EXIT.
  3794. 060100 990-END.
  3795. 060200     CLOSE FILE-D4.
  3796. 060300     CLOSE FILE-D1 FILE-D3 FILE-P1 FILE-D2.
  3797. 060400     STOP RUN.
  3798. 060500 XXXXXX.
  3799. 000000*-----------------------------------------------------------------
  3800. 000100 IDENTIFICATION DIVISION.
  3801. 000200 PROGRAM-ID. ES050P.
  3802. 000300*        CREATES PLANT SUMMARY FILE
  3803. 000400*
  3804. 000500 AUTHOR. RON BAKER.
  3805. 000600 DATE-WRITTEN. 04/24/79.
  3806. 000700 DATE-COMPILED.
  3807. 000800 ENVIRONMENT DIVISION.
  3808. 000900 CONFIGURATION SECTION.
  3809. 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
  3810. 001100 OBJECT-COMPUTER. LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
  3811. 001200 INPUT-OUTPUT SECTION.
  3812. 001300 FILE-CONTROL.
  3813. 001400     SELECT FILE-D7    ASSIGN TO D7
  3814. 001500         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  3815. 001600     SELECT FILE-D8    ASSIGN TO D8
  3816. 001700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  3817. 001800     SELECT FILE-P1    ASSIGN TO P1
  3818. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  3819. 002000 DATA DIVISION.
  3820. 002100 SUB-SCHEMA SECTION.
  3821. 002200 DB  CODVAL2 WITHIN BLMDIC.
  3822. 002300 FILE SECTION.
  3823. 002400 FD  FILE-D7
  3824. 002500     CODE-SET IS GBCD
  3825. 002600     LABEL RECORDS ARE STANDARD
  3826. 002700     DATA RECORD IS FDR-D7.
  3827. 002800 01  FDR-D7.
  3828. 002900     03  SWAT-CNTL-D7.
  3829. 003000         05  SDRP-D7.
  3830. 003100             07  SD-D7.
  3831. 003200                 09  ST-D7  PIC XX.
  3832. 003300                 09  DS-D7  PIC XX.
  3833. 003400             07  FILLER  PIC X(4).
  3834. 003500         05  FILLER  PIC X(12).
  3835. 003600     03  REC-KEY-D7         PIC 9.
  3836. 003700     03  REC-TYP-D7         PIC X(2).
  3837. 003800     03  FMT-NUM-D7         PIC 9.
  3838. 003900     03  FMT-CD-D7         PIC X.
  3839. 004000     03  SORT-CNTL.
  3840. 004100         05  SPECIES-D7   PIC X(7).
  3841. 004200         05  PLOT-TOT-CHRZ-D7    PIC 99.
  3842. 004300         05  FILLER              PIC XXX.
  3843. 004400     03  FILLER   PIC X(19).
  3844. 004500     03  CN-D7    PIC 999.
  3845. 004600     03  ACD-D7   PIC 999.
  3846. 004700     03  CNN-D7  PIC 999.
  3847. 004800     03  FILLER       PIC X(10).
  3848. 004900     03  PN4U      PIC 9.
  3849. 005000     03  FILLER      PIC X(6).
  3850. 005100     03  PN5U      PIC 9.
  3851. 005200     03  FILLER      PIC X(34).
  3852. 005300     03  PN10U      PIC 9.
  3853. 005400     03  FILLER      PIC X(8).
  3854. 005500 FD  FILE-D8
  3855. 005600     CODE-SET IS GBCD
  3856. 005700     LABEL RECORDS ARE STANDARD
  3857. 005800     DATA RECORD IS FDR-D8.
  3858. 005900 01  FDR-D8.
  3859. 006000     03  FILLER   PIC X(153).
  3860. 006100     03  PLOTS-CHRZ-D8  PIC 99.
  3861. 006200     03  FILLER  PIC X.
  3862. 006300 FD  FILE-P1
  3863. 006400     CODE-SET IS GBCD
  3864. 006500     LABEL RECORDS ARE STANDARD
  3865. 006600     DATA RECORD IS FDR-P1.
  3866. 006700 01  FDR-P1   PIC X(132).
  3867. 006800 WORKING-STORAGE SECTION.
  3868. 006900 77  SPEC-HLD          PIC X(7) VALUE SPACE.
  3869. 007000 77  SWAT-CNTL-BARREN   PIC X(20)   VALUE SPACE.
  3870. 007100 77  SPEC-TEST-CNT   PIC 999  VALUE 000.
  3871. 007200 77  PLOTS-CHRZ-HLD      PIC 99     VALUE ZERO.
  3872. 007300 77  PLOTS-CHRZ-HLD-2      PIC 99     VALUE ZERO.
  3873. 007400 77  END-SW            PIC 9    VALUE ZERO.
  3874. 007500 77  PRT-SW            PIC 9    VALUE 1.
  3875. 007600 77  AVAIL-SW            PIC 9    VALUE ZERO.
  3876. 007700 77  CHRZ-SW            PIC 9    VALUE 2.
  3877. 007800 77  AUDIT             PIC 9    VALUE ZERO.
  3878. 007900 77  HC-HLD            PIC 9    VALUE ZERO.
  3879. 008000 77  FC-KEY            PIC 9    VALUE ZERO.
  3880. 008100 77  CON96            PIC V99    VALUE .96.
  3881. 008200 77  RK-SW             PIC 9    VALUE ZERO.
  3882. 008300 77  AGE               PIC 9    VALUE ZERO.
  3883. 008400 77  SUB1              PIC 99   VALUE ZERO.
  3884. 008500 77  SUB2              PIC 99   VALUE ZERO.
  3885. 008600 77  SUB3              PIC 99   VALUE ZERO.
  3886. 008700 77  SUB4              PIC 99   VALUE ZERO.
  3887. 008800 77  SUB5              PIC 99   VALUE ZERO.
  3888. 008900 77  SUB6              PIC 99   VALUE ZERO.
  3889. 009000 77  PLANT-TOT-HLD    PIC 999  VALUE ZERO.
  3890. 009100 77  PLANT-TOTAL       PIC 9(5)  VALUE ZERO.
  3891. 009200 77  TYPE-SPEC-HLD    PIC X VALUE SPACE.
  3892. 009300 77  SDRP-HLD    PIC X(8) VALUE SPACE.
  3893. 009400 77  SWAT-SW           PIC 9    VALUE ZERO.
  3894. 009500 77  SPEC-SW           PIC 9    VALUE ZERO.
  3895. 009600 77   PG-CNT           PIC 9(5)  VALUE ZERO.
  3896. 009700 77   REC-CNT           PIC 9(5)  VALUE ZERO.
  3897. 009800 77  LINE-CNT          PIC 99    VALUE 99.
  3898. 009900 01 HLD-DT.
  3899. 010000     03  YR-DT   PIC XX.
  3900. 010100     03  MO-DT   PIC 99.
  3901. 010200     03  DY-DT   PIC XX.
  3902. 010300     03  FUNC-HLD.
  3903. 010400         05  ST-NM-HLD    PIC X(10).
  3904. 010500         05  FILLER       PIC X(14).
  3905. 010600     03  EXPL-HLD.
  3906. 010700         05  DIST-NM-HLD    PIC X(10).
  3907. 010800         05  FILLER        PIC X.
  3908. 010900         05  RA-NM-HLD     PIC X(12).
  3909. 011000         05  FILLER        PIC X.
  3910. 011100         05  PU-NM-HLD     PIC X(15).
  3911. 011200         05  FILLER        PIC X.
  3912. 011300 01  FC-AC-CNTL.
  3913. 011400     03  FAC-IN.
  3914. 011500         05  SC-FAC    PIC X(20).
  3915. 011600         05  RK-FAC    PIC 9.
  3916. 011700         05  SPEC-FAC   PIC X(7).
  3917. 011800         05  FAPN-FAC   PIC XXX.
  3918. 011900     03  FAC-HLD     PIC X(31).
  3919. 012000 01  CONTROL-HLD.
  3920. 012100     03  SWAT-CNTL-HLD.
  3921. 012200         05  SDRP-SCH.
  3922. 012300             07  SDR-SCH.
  3923. 012400                 09  SD-SCH.
  3924. 012500                     11  ADST-CD-SCH       PIC XX.
  3925. 012600                     11  DIST-CD-SCH       PIC XX.
  3926. 012700                 09  RA-CD-SCH       PIC XX.
  3927. 012800             07  PLU-CD-SCH        PIC XX.
  3928. 012900
  3929. 013000         05  ALLOT-NUM-SCH    PIC 9999.
  3930. 013100         05  PASTURE-NUM-SCH  PIC 99.
  3931. 013200         05  SWAT-SCH.
  3932. 013300           07  SWA-SCH           PIC XXXX.
  3933. 013400           07  TRN-NUM-SCH       PIC 99.
  3934. 013500     03  REC-KEY-SCH           PIC 9.
  3935. 013600     03  RCD-SCH.
  3936. 013700         05  REC-TYP-SCH       PIC X(2).
  3937. 013800         05  FMT-NUM-SCH       PIC 9.
  3938. 013900         05  FMT-CD-SCH        PIC X.
  3939. 014000     03  KEYS-SCH.
  3940. 014100         05  SPECIES-CD-SCH    PIC X(7).
  3941. 014200         05 SK-0.
  3942. 014300             07  PN-S-0        PIC 99.
  3943. 014400             07  FILLER        PIC X.
  3944. 014500         05  SK-6 REDEFINES SK-0.
  3945. 014600             07  FC-S-6        PIC 9.
  3946. 014700             07  PN-S-6        PIC 99.
  3947. 014800         05  SK-7 REDEFINES SK-0.
  3948. 014900             07  AC-S-7        PIC X.
  3949. 015000             07  PN-S-7        PIC 99.
  3950. 015100         05  FILLER     PIC XX.
  3951. 015200     03  KEYS-IN.
  3952. 015300         05  SPECIES-IN        PIC X(7).
  3953. 015400         05 SK-0-IN.
  3954. 015500             07  PN-S-0-IN     PIC 99.
  3955. 015600             07  FILLER        PIC X.
  3956. 015700         05  SK-6-IN REDEFINES SK-0-IN.
  3957. 015800             07  FC-S-6-IN     PIC 9.
  3958. 015900             07  PN-S-6-IN     PIC 99.
  3959. 016000         05  SK-7-IN REDEFINES SK-0-IN.
  3960. 016100             07  AC-S-7-IN     PIC X.
  3961. 016200             07  PN-S-7-IN     PIC 99.
  3962. 016300         05  FILLER   PIC XX.
  3963. 016400 01  TABL-AREA.
  3964. 016500     03  MON-V  PIC X(36)  VALUE   "JANFEBMARAPRMAYJUNJULAUGSEPOCT
  3965. 016600-                                  "NOVDEC".
  3966. 016700     03  MON-T  REDEFINES  MON-V  PIC XXX  OCCURS 12 TIMES.
  3967. 016800 01  HEAD-1.
  3968. 016900     03  FILLER   PIC X(5) VALUE "PCN: ".
  3969. 017000     03  PCN-HD-1 PIC X(6) VALUE "ES050P".
  3970. 017100     03  FILLER   PIC X(14)  VALUE " REPORT DATE: ".
  3971. 017200     03  DAY-HD-1  PIC 99.
  3972. 017300     03  FILLER    PIC X VALUE SPACE.
  3973. 017400     03  MTH-HD-1  PIC XXX.
  3974. 017500     03  FILLER    PIC X VALUE SPACE.
  3975. 017600     03  YR-HD-1   PIC 99.
  3976. 017700     03  FILLER    PIC X(12) VALUE SPACE.
  3977. 017800     03  FILLER  PIC X(28) VALUE "UNITED STATES DEPARTMENT OF ".
  3978. 017900     03  FILLER  PIC X(36) VALUE "THE INTERIOR".
  3979. 018000     03  FILLER  PIC X(9)  VALUE "PAGE NO: ".
  3980. 018100     03  PG-HD-1 PIC ZZ,ZZZ.
  3981. 018200     03  FILLER  PIC X(7)  VALUE SPACE.
  3982. 018300 01  P-SPACE   PIC X(132)  VALUE SPACE.
  3983. 018400 01  HEAD-2.
  3984. 018500     03  FILLER  PIC X(53) VALUE SPACE.
  3985. 018600     03  FILLER  PIC X(25) VALUE "BUREAU OF LAND MANAGEMENT".
  3986. 018700     03  FILLER  PIC X(54) VALUE SPACE.
  3987. 018800 01  HEAD-3.
  3988. 018900     03  FILLER  PIC X(07)  VALUE "STATE: ".
  3989. 019000     03  ST-HD-3 PIC XX.
  3990. 019100     03  FILLER  PIC X VALUE SPACE.
  3991. 019200     03  SN-HD-3 PIC X(12).
  3992. 019300     03  FILLER  PIC X(08)  VALUE "  DIST: ".
  3993. 019400     03  DS-HD-3 PIC XX.
  3994. 019500     03  FILLER  PIC X VALUE SPACE.
  3995. 019600     03  DN-HD-3 PIC X(15).
  3996. 019700     03  FILLER  PIC X(08)  VALUE "    RA: ".
  3997. 019800     03  RA-HD-3 PIC XX.
  3998. 019900     03  FILLER  PIC X VALUE SPACE.
  3999. 020000     03  RAN-HD-3 PIC X(15).
  4000. 020100     03  FILLER  PIC X(6)   VALUE "  PU: ".
  4001. 020200     03  PS-HD-3 PIC 99.
  4002. 020300     03  FILLER  PIC X VALUE SPACE.
  4003. 020400     03  PN-HD-3 PIC X(17).
  4004. 020500     03  FILLER   PIC X(13)  VALUE "  ALLOTMENT: ".
  4005. 020600     03  AN-HD-3   PIC 9999   VALUE ZERO.
  4006. 020700     03  FILLER   PIC X   VALUE SPACE.
  4007. 020800     03  APS-HD-3  PIC 99  VALUE ZERO.
  4008. 020900     03  FILLER  PIC X(14)  VALUE SPACE.
  4009. 021000 01  HEAD-4.
  4010. 021100     03  FILLER  PIC X(54)  VALUE SPACE.
  4011. 021200     03  FILLER  PIC X(23)  VALUE "VEGETATION SWAT SUMMARY".
  4012. 021300     03  FILLER  PIC X(55)  VALUE SPACE.
  4013. 021400 01  HEAD-5.
  4014. 021500     03  FILLER  PIC X(30) VALUE "SWA TRN PLANT TYP             ".
  4015. 021600     03  FILLER  PIC X(30) VALUE "P L A N T S  W / I  A C R E   ".
  4016. 021700     03  FILLER  PIC X(30) VALUE "             GRAMS  &  PROD WG".
  4017. 021800     03  FILLER  PIC X(30) VALUE "T       TOTAL    AVERAGE  WEIG".
  4018. 021900     03  FILLER  PIC X(12) VALUE "HTED-AVERAGE".
  4019. 022000 01  HEAD-6.
  4020. 022100     03  FILLER  PIC X(30) VALUE "                      B Y  F O".
  4021. 022200     03  FILLER  PIC X(30) VALUE " R M  C L A S S  &  A G E  C L".
  4022. 022300     03  FILLER  PIC X(30) VALUE " A S S        BY  HT-CLS-CD   ".
  4023. 022400     03  FILLER  PIC X(30) VALUE "        PLANTS   HGT CRWN AVAI".
  4024. 022500     03  FILLER  PIC X(12) VALUE "L UTIL PHENO".
  4025. 022600 01  HEAD-7.
  4026. 022700     03  FILLER  PIC X(30) VALUE "                       1 S    ".
  4027. 022800     03  FILLER  PIC X(30) VALUE "2 P    3 Y    4 M    5 O    6 ".
  4028. 022900     03  FILLER  PIC X(30) VALUE "D      R     (1)    (2)    (3)".
  4029. 023000     03  FILLER  PIC X(42) VALUE "    (4)".
  4030. 023100 01  DET-1.
  4031. 023200     03  SWA-P         PIC X(4).
  4032. 023300     03  FILLER        PIC X.
  4033. 023400     03  TRN-P         PIC 99.
  4034. 023500     03  FILLER        PIC X.
  4035. 023600     03  SPECIES-CD-P  PIC X(7).
  4036. 023700     03  FILLER        PIC X.
  4037. 023800     03  SPECIES-TYPE-P          PIC X.
  4038. 023900    03  PFC-P     OCCURS 6 TIMES.
  4039. 024000        05  FILLER     PIC XX.
  4040. 024100        05  PLANTS-FORM-CLS-P   PIC Z(5).
  4041. 024200     03  FILLER        PIC X(8)  VALUE SPACE.
  4042. 024300     03  GHC-P       OCCURS 4 TIMES.
  4043. 024400         05  FILLER    PIC XX.
  4044. 024500         05  GRAMS-HGT-CLS-P  PIC Z(5).
  4045. 024600     03  FILLER        PIC XXX     VALUE SPACE.
  4046. 024700     03  TOT-PLANTS-P  PIC Z(5).
  4047. 024800     03  FILLER        PIC XX.
  4048. 024900     03  AVG-HGT-P     PIC ZZZ.9.
  4049. 025000     03  FILLER        PIC X.
  4050. 025100     03  AVG-CROWN-P   PIC ZZ.9.
  4051. 025200     03  FILLER        PIC XX.
  4052. 025300     03  WTD-AVG-AVAIL-P   PIC 999.
  4053. 025400     03  FILLER        PIC XXX.
  4054. 025500     03  WTD-AVG-UTIL-P   PIC  999.
  4055. 025600     03  FILLER        PIC XXX.
  4056. 025700     03  WTD-AVG-PHNO-P     PIC 9.
  4057. 025800     03  FILLER     PIC XX.
  4058. 025900 01  DET-2.
  4059. 026000     03  FILLER      PIC X(19).
  4060. 026100    03  PAC-P     OCCURS 7 TIMES.
  4061. 026200        05  FILLER       PIC XX.
  4062. 026300        05  PLANTS-AGE-CLS-P   PIC Z(5).
  4063. 026400     03  FILLER           PIC X  VALUE SPACE.
  4064. 026500     03  PHC-P       OCCURS 4 TIMES.
  4065. 026600         05  FILLER     PIC XX.
  4066. 026700         05  PROD-HGT-CLS-P    PIC Z(5).
  4067. 026800     03  FILLER      PIC X(35)  VALUE SPACE.
  4068. 026900 01  DISP-RK8.
  4069. 027000     03  DRK8-1  PIC X(21).
  4070. 027100     03  DRK8-2   PIC X(65).
  4071. 027200     03  DRK8-3    PIC X(64).
  4072. 027300 COPY DBSTATUS OF TPCOBOLIB.
  4073. 027400 COPY  REC-KEY0 IN LIBRARY1.
  4074. 027500 COPY  REC-KEY5 IN LIBRARY1.
  4075. 027600 COPY  REC-KEY6 IN LIBRARY1.
  4076. 027700 COPY  REC-KEY7 IN LIBRARY1.
  4077. 027800 COPY  REC-KEY8 IN LIBRARY1.
  4078. 027900 01  PLANT-TOT-TABLE.
  4079. 028000     03  TOT-PLANTS    PIC 999   OCCURS 99 TIMES.
  4080. 028100 01  PLANT-CAL-TABLE.
  4081. 028200     03  PC-TAB        OCCURS 10 TIMES.
  4082. 028300         05  TK-TAB    PIC 99.
  4083. 028400         05  CHAR-TAB  PIC 999.
  4084. 028500 01  PLANT-CAL-HLD.
  4085. 028600     03  PC-SUB        PIC 99.
  4086. 028700     03  PC-PCT        PIC 999V99.
  4087. 028800     03  PC-CHAR       PIC 999.
  4088. 028900     03  PC-NOT-CHAR   PIC 999.
  4089. 029000     03  PC-TOT-PLANTS PIC 999.
  4090. 029100     03  PC-TABKEY        PIC 99.
  4091. 029200 01  PROD-WGT-HLD.
  4092. 029300     03  PW-PLOT-TOT   PIC 99.
  4093. 029400     03  PW-GRAMS    PIC 9(7).
  4094. 029500     03  PW-GRAMS-HLD    PIC 9(7).
  4095. 029600     03  PW-LBS-ACRE       PIC 9(8).
  4096. 029700     03  PW-SIZE   PIC 999V99.
  4097. 029800     03  PW-WUAF       PIC 999.
  4098. 029900     03  PW-WAUF       PIC 999V99.
  4099. 030000     03  PW-GRP-PROD.
  4100. 030100         05  PW-PROD        PIC 9(5)  OCCURS 4 TIMES.
  4101. 030200 01  UTIL-PHENO-TABLE.
  4102. 030300     03  UP-TAB        OCCURS 40 TIMES.
  4103. 030400         05  UTIL-TB     PIC 9.
  4104. 030500         05  PHNO-TB     PIC 9.
  4105. 030600         05  MID-PT-TB   PIC 999.
  4106. 030700         05  GRAM-UP-TB  PIC 9(5).
  4107. 030800         05  AVAIL-TB  PIC 9V99.
  4108. 030900         05  PHNO-TAB     PIC 9.
  4109. 031000 01  UTIL-PHENO-HLD.
  4110. 031100     03  UTIL-GRAMS-TOT      PIC 9(8).
  4111. 031200     03  UTIL-MID-POINT-TOT  PIC 9(4)V999.
  4112. 031300     03  UTIL-MP-ACUM        PIC 9(4)V999.
  4113. 031400     03  PHNO-GRAMS-TOT      PIC 9(8)V99.
  4114. 031500     03  PHNO-ACUM           PIC 9(8).
  4115. 031600     03  PHNO-AVG-TOT        PIC 9(8).
  4116. 031700     03  PHNO-AVG-PLOT-TOT        PIC 9(8).
  4117. 031800     03  PHNO-HLD            PIC 9.
  4118. 031900     03  UTIL-AVG            PIC 9V99.
  4119. 032000     03  UTIL-AVG-RD REDEFINES UTIL-AVG    PIC 999.
  4120. 032100     03  UTIL-AVG-DEC-RD REDEFINES UTIL-AVG.
  4121. 032200         05  UTIL-AVG-1  PIC 9.
  4122. 032300         05  UTIL-AVG-2  PIC 99.
  4123. 032400     03  MID-PT-HLD     PIC 999.
  4124. 032500     03  MID-PT-HLD-RD REDEFINES MID-PT-HLD  PIC 9V99.
  4125. 032600     03  UTIL-HLD            PIC 9.
  4126. 032700     03  PHNO-AVG            PIC 9.
  4127. 032800     03  PHNO-PLOT-AVG            PIC 9.
  4128. 032900     03  PHNO-PLOT-TOT   PIC 99.
  4129. 033000 01  HT-CLS-TABLE.
  4130. 033100     03  HT-CLS-TAB.
  4131. 033200         05  GRAM-HC-TB-RD.
  4132. 033300             07  GRAM-HC-TB      PIC 9(5)  OCCURS 4.
  4133. 033400         05  PLOT-TOT-HC-TB  PIC 99   OCCURS 4 TIMES.
  4134. 033500 01  FORM-CLS-TABLE.
  4135. 033600     03  FORM-CLS-TAB.
  4136. 033700         05  PLOT-TOT-FC-TB      PIC 999   OCCURS 6 TIMES.
  4137. 033800         05  PLANT-TOT-FC-TB     PIC 999   OCCURS 6 TIMES.
  4138. 033900         05  PIA-FC-RD.
  4139. 034000             07  PIA-FC              PIC 9(5)  OCCURS 6 TIMES.
  4140. 034100 01  AGE-CLS-TABLE.
  4141. 034200     03  AGE-CLS-TAB.
  4142. 034300         05  PLOT-TOT-AC-TB      PIC 999   OCCURS 8 TIMES.
  4143. 034400         05  PLANT-TOT-AC-TB     PIC 999   OCCURS 8 TIMES.
  4144. 034500         05  PIA-AC-RD.
  4145. 034600             07  PIA-AC              PIC 9(5)  OCCURS 8 TIMES.
  4146. 034700         05  PIA-AC-RD2 REDEFINES PIA-AC-RD.
  4147. 034800             07  PIA-AC2        PIC X(35).
  4148. 034900             07  PIA-AC3        PIC 9(5).
  4149. 035000 01  FORM-AGE-HOLD.
  4150. 035100     03  PLOT-NUM-FAH     PIC 99.
  4151. 035200     03  ACRE-FRAC-FAH    PIC 999.
  4152. 035300     03  TYPE-SP-FAH      PIC X.
  4153. 035400     03  ACRE-SF-TOT      PIC 9(6)V9.
  4154. 035500     03  PLOT-SAMP-SZ-FAH PIC 999V99.
  4155. 035600     03  PLANTS-ACUM      PIC 9(8).
  4156. 035700 01  AVG-HGT-CROWN-AVL.
  4157. 035800     03  PLANT-TOT-HGT    PIC 999.
  4158. 035900     03  PLANT-TOT-CROWN  PIC 999.
  4159. 036000     03  PLANT-TOT-AVAIL  PIC 999.
  4160. 036100     03  AVG-HGT-SUM      PIC 9(6)V9.
  4161. 036200     03  AVG-HGT-TOT      PIC 9(6)V9.
  4162. 036300     03  AVG-HGT          PIC 999V9.
  4163. 036400     03  AVG-CROWN-SUM    PIC 9(5)V9.
  4164. 036500     03  AVG-CROWN-TOT    PIC 9(5)V9.
  4165. 036600     03  AVG-CROWN        PIC 99V9.
  4166. 036700     03  AVG-AVAIL-SUM    PIC 9(6)V99.
  4167. 036800     03  GRAM-UP-TB-HLD    PIC 9(5).
  4168. 036900     03  AVG-AVAIL-PCT    PIC 9V99.
  4169. 037000     03  AVG-AVAIL-TOT    PIC 9(6)V99.
  4170. 037100     03  AVG-AVAIL        PIC 999V99.
  4171. 037200     03  AVG-AVAIL-RD REDEFINES AVG-AVAIL.
  4172. 037300         05  AVG-AV-00      PIC 99.
  4173. 037400         05  AVG-AV-PCT     PIC 999.
  4174. 037500 01  MID-POINT-TABLE.
  4175. 037600     03  MPT PIC 9(10) VALUE 1030507090.
  4176. 037700     03  MID-PT REDEFINES MPT    PIC 99    OCCURS 5.
  4177. 037800 01  DIS-HD1.
  4178. 037900     03  FILLER  PIC X(30) VALUE "AUDIT TRAIL FOR SWAT-SPECIES: ".
  4179. 038000     03  DIS-SS.
  4180. 038100         05  DIS-ST    PIC XX.
  4181. 038200         05  FILLER    PIC X.
  4182. 038300         05  DIS-SWAT  PIC X(6).
  4183. 038400         05  FILLER    PIC X.
  4184. 038500         05  DIS-SP1    PIC X(7).
  4185. 038600         05  DIS-SP2    PIC X(7).
  4186. 038700         05  DIS-SP3    PIC X(7).
  4187. 038800 01  DIS-HD2.
  4188. 038900     03  FILLER  PIC X(30) VALUE "TOT-PLANTS PLOT-SIZE  PLOT-TOT".
  4189. 039000     03  FILLER  PIC X(30) VALUE "-BY-HTC  WGT BY HTC ----------".
  4190. 039100     03  FILLER  PIC X(30) VALUE "--  PLOT-TOT BY AGE ----------".
  4191. 039200     03  FILLER  PIC X(30) VALUE "-----  PLOT-TOT BY FORM ------".
  4192. 039300 01  DIS-HD3.
  4193. 039400     03  FILLER  PIC X(30) VALUE "TOT-HGT AVG-HGT-TOT  TOT-CRN A".
  4194. 039500     03  FILLER  PIC X(30) VALUE "VG-CRN-TOT  TOT-AVAIL AVG-AVAI".
  4195. 039600     03  FILLER  PIC X(30) VALUE "L-TOT UTIL-AVG WGTD-AVG-UTIL-F".
  4196. 039700     03  FILLER  PIC X(30) VALUE "AC ACRE-FRAC-FAH ACRE-SF-TOT  ".
  4197. 039800 01  DIS-DT1.
  4198. 039900     03  FILLER   PIC XXX.
  4199. 040000     03  TP-DD       PIC 999.
  4200. 040100     03  FILLER  PIC X(5).
  4201. 040200     03  PS1-DD   PIC 9.
  4202. 040300     03  FILLER  PIC X.
  4203. 040400     03  PS2-DD    PIC 999.99.
  4204. 040500     03  FILLER   PIC X(3).
  4205. 040600     03  PT-DD-TB    OCCURS 4 TIMES.
  4206. 040700         05  PT-DD     PIC 999.
  4207. 040800         05  FILLER   PIC X.
  4208. 040900     03  FILLER   PIC X.
  4209. 041000     03  WGT-DD-TB    OCCURS 4 TIMES.
  4210. 041100         05  WGT-DD     PIC 9(5).
  4211. 041200         05  FILLER   PIC X.
  4212. 041300     03  FILLER   PIC X.
  4213. 041400     03  PT-AC-DD-TB    OCCURS 7 TIMES.
  4214. 041500         05  PT-AC-DD  PIC 999.
  4215. 041600         05  FILLER    PIC X.
  4216. 041700     03  FILLER   PIC X.
  4217. 041800     03  PT-FC-DD-TB    OCCURS 6 TIMES.
  4218. 041900         05  PT-FC-DD   PIC 999.
  4219. 042000         05  FILLER     PIC X.
  4220. 042100 01  DIS-DT2.
  4221. 042200     03  FILLER  PIC XX.
  4222. 042300     03  TH-DD   PIC 999.
  4223. 042400     03  FILLER  PIC XXXX.
  4224. 042500     03  AHT-DD  PIC 9(6).9.
  4225. 042600     03  FILLER  PIC XXXXXX.
  4226. 042700     03  TC-DD  PIC 999.
  4227. 042800     03  FILLER  PIC X(5).
  4228. 042900     03  ACT-DD  PIC 9(5).9.
  4229. 043000     03  FILLER  PIC X(7).
  4230. 043100     03  TA-DD  PIC 999.
  4231. 043200     03  FILLER  PIC X(8).
  4232. 043300     03  AAT-DD  PIC 9(6).
  4233. 043400     03  FILLER  PIC X(6).
  4234. 043500     03  UA-DD  PIC 999.
  4235. 043600     03  FILLER  PIC X(11).
  4236. 043700     03  WAUF-DD  PIC 999.
  4237. 043800     03  FILLER  PIC X(12).
  4238. 043900     03  AFF-DD  PIC 999.
  4239. 044000     03  FILLER  PIC X(7).
  4240. 044100     03  AST-DD  PIC 9(6).9.
  4241. 044200 01  SEL-ST-AUDIT-SWAT-SPECIES.
  4242. 044300     03  SEL-ST    PIC XX    VALUE "NM".
  4243. 044400     03  FILLER    PIC X    VALUE SPACE.
  4244. 044500     03  AUDIT-SWAT    PIC X(6)  VALUE "Z00101".
  4245. 044600     03  FILLER      PIC X     VALUE SPACE.
  4246. 044700     03  AUDIT-SPEC1   PIC X(7)  VALUE "ERPU8  ".
  4247. 044800     03  AUDIT-SPEC2   PIC X(7)  VALUE "GUSA2  ".
  4248. 044900     03  AUDIT-SPEC3   PIC X(7)  VALUE "HIMU2  ".
  4249. 045000 01  DIS-REC.
  4250. 045100     03  PAR-DR   PIC 999.
  4251. 045200     03  FILLER   PIC XX.
  4252. 045300     03  FAN-DR   PIC X(25).
  4253. 045400     03  PR1-DR.
  4254. 045500         05  FILLER    PIC X.
  4255. 045600         05  SB1-DR    PIC 99.
  4256. 045700         05  FILLER    PIC XX.
  4257. 045800     03  FA-DR    PIC 9(8).
  4258. 045900     03  FA1-DR REDEFINES FA-DR  PIC 9(6).9.
  4259. 046000     03  FA2-DR REDEFINES FA-DR  PIC 9(5).99.
  4260. 046100     03  FA3-DR REDEFINES FA-DR  PIC 9(4).999.
  4261. 046200     03  FILLER  PIC XX.
  4262. 046300     03  SGN-DR  PIC X.
  4263. 046400     03  FILLER  PIC XX.
  4264. 046500     03  FB-DR    PIC 9(8).
  4265. 046600     03  FB1-DR REDEFINES FB-DR  PIC 9(6).9.
  4266. 046700     03  FB2-DR REDEFINES FB-DR  PIC 9(5).99.
  4267. 046800     03  FB3-DR REDEFINES FB-DR  PIC 9(4).999.
  4268. 046900     03  FBS-DR REDEFINES FB-DR  PIC X(8).
  4269. 047000     03  FILLER  PIC XX.
  4270. 047100     03  FBN-DR   PIC X(25).
  4271. 047200     03  PR2-DR.
  4272. 047300         05  FILLER    PIC X.
  4273. 047400         05  SB2-DR    PIC 99.
  4274. 047500         05  FILLER    PIC XX.
  4275. 047600     03  FILLER-DR  PIC XXX  VALUE " = ".
  4276. 047700     03  FC-DR    PIC 9(8).
  4277. 047800     03  FC1-DR REDEFINES FC-DR  PIC 9(6).9.
  4278. 047900     03  FC2-DR REDEFINES FC-DR  PIC 9(5).99.
  4279. 048000     03  FC3-DR REDEFINES FC-DR  PIC 9(4).999.
  4280. 048100     03  FILLER  PIC XX.
  4281. 048200     03  FCN-DR   PIC X(25).
  4282. 048300     03  PR3-DR.
  4283. 048400         05  FILLER    PIC X.
  4284. 048500         05  SB3-DR    PIC 99.
  4285. 048600         05  FILLER    PIC XX.
  4286. 048700 PROCEDURE DIVISION.
  4287. 048800 010-HOUSEKEEPING.
  4288. 048900     MOVE SEL-ST-AUDIT-SWAT-SPECIES TO DIS-SS.
  4289. 049000     DISPLAY DIS-HD1.
  4290. 049100      ACCEPT HLD-DT FROM DATE.
  4291. 049200     MOVE YR-DT TO YR-HD-1.
  4292. 049300     MOVE DY-DT TO DAY-HD-1.
  4293. 049400     MOVE MON-T (MO-DT) TO MTH-HD-1.
  4294. 049500     OPEN INPUT FILE-D7,
  4295. 049600          OUTPUT FILE-D8, FILE-P1.
  4296. 049700     READY   DIC-DE.
  4297. 049800     MOVE SPACE TO DIS-REC.
  4298. 049900     INITIALIZE PLANT-TOT-TABLE, PLANT-CAL-TABLE,
  4299. 050000         PLANT-CAL-HLD, UTIL-PHENO-TABLE,
  4300. 050100         UTIL-PHENO-HLD, HT-CLS-TABLE, FORM-CLS-TABLE,
  4301. 050200         AGE-CLS-TABLE, FORM-AGE-HOLD, AVG-HGT-CROWN-AVL
  4302. 050300         FC-AC-CNTL PROD-WGT-HLD DIS-DT1 DIS-DT2 DIS-REC.
  4303. 050400     PERFORM 020-RD-IN THRU 030-EXIT.
  4304. 050500     GO TO 040-LOAD-REC.
  4305. 050600 020-RD-IN.
  4306. 050700     READ FILE-D7 AT END
  4307. 050800         MOVE 1 TO END-SW GO TO 058-CHK-CAL-SW.
  4308. 050900     IF SPECIES-D7 = "ZZBAREN"
  4309. 051000         MOVE "BARREN " TO SPECIES-D7.
  4310. 051100     IF (SPECIES-D7 = "BARREN ") AND
  4311. 051200         (SWAT-CNTL-D7 = SWAT-CNTL-HLD)
  4312. 051300         GO TO 020-RD-IN.
  4313. 051400     IF (SPECIES-D7 = "BARREN ") AND
  4314. 051500         (SWAT-CNTL-D7 = SWAT-CNTL-BARREN)
  4315. 051600         GO TO 020-RD-IN.
  4316. 051700     IF SPECIES-D7 = "BARREN "
  4317. 051800         MOVE SWAT-CNTL-D7 TO SWAT-CNTL-BARREN
  4318. 051900         INITIALIZE REC-KEY8
  4319. 052000         MOVE 8 TO REC-KEY-RK8
  4320. 052100         MOVE SWAT-CNTL-BARREN TO SWAT-RK8
  4321. 052200         MOVE ZERO TO PLANT-TYP-RK8
  4322. 052300         MOVE "BARREN " TO SPECIES-KEY-RK8
  4323. 052400         MOVE REC-KEY8 TO FDR-D8
  4324. 052500         MOVE ZERO TO PLOTS-CHRZ-D8
  4325. 052600         WRITE FDR-D8
  4326. 052700         ADD 1 TO REC-CNT
  4327. 052800         GO TO 020-RD-IN.
  4328. 052900*    IF SPEC-TEST-CNT > 002
  4329. 053000*        MOVE 1 TO END-SW GO TO 058-CHK-CAL-SW.
  4330. 053100*    IF ST-D7 NOT = SEL-ST GO TO 020-RD-IN.
  4331. 053200     IF (REC-KEY-D7 = 0) AND (SPECIES-D7 = SPACE)
  4332. 053300         AND (SD-D7 = "NM03")
  4333. 053400         MOVE 03 TO PLOT-TOT-CHRZ-D7.
  4334. 053500     IF (REC-KEY-D7 = 0) AND (SPECIES-D7 = SPACE)
  4335. 053600         AND (CHRZ-SW = 2)
  4336. 053700         MOVE ZERO TO CHRZ-SW
  4337. 053800         MOVE PLOT-TOT-CHRZ-D7 TO PLOTS-CHRZ-HLD
  4338. 053900         GO TO 020-RD-IN.
  4339. 054000     IF (REC-KEY-D7 = 0) AND (SPECIES-D7 = SPACE)
  4340. 054100         MOVE 1 TO CHRZ-SW
  4341. 054200         MOVE PLOT-TOT-CHRZ-D7 TO PLOTS-CHRZ-HLD-2
  4342. 054300         GO TO 020-RD-IN.
  4343. 054400     MOVE SORT-CNTL TO KEYS-IN.
  4344. 054500     INITIALIZE FAC-HLD.
  4345. 054600 020-EXIT-RD.
  4346. 054700     GO TO 030-MV-IN.
  4347. 054800 025-CK-SUM.
  4348. 054900     IF RK-SW = 1
  4349. 055000         MOVE ZERO TO RK-SW
  4350. 055100         PERFORM 030-MV-IN
  4351. 055200         GO TO 055-PASS.
  4352. 055300     GO TO 460-BUILD-SUMMARY.
  4353. 055400 030-MV-IN.
  4354. 055500     MOVE SWAT-CNTL-D7 TO SWAT-CNTL-HLD SC-FAC.
  4355. 055600     MOVE REC-KEY-D7 TO REC-KEY-SCH RK-FAC.
  4356. 055700     MOVE REC-TYP-D7 TO REC-TYP-SCH.
  4357. 055800     MOVE FMT-NUM-D7 TO FMT-NUM-SCH.
  4358. 055900     MOVE FMT-CD-D7 TO FMT-CD-SCH.
  4359. 056000     MOVE SPECIES-D7 TO SPECIES-CD-SCH SPEC-FAC.
  4360. 056100     MOVE KEYS-IN TO KEYS-SCH.
  4361. 056200     MOVE ALLOT-NUM-SCH TO AN-HD-3.
  4362. 056300     MOVE PASTURE-NUM-SCH TO APS-HD-3.
  4363. 056400     MOVE SK-0 TO FAPN-FAC.
  4364. 056500 030-EXIT.
  4365. 056600     EXIT.
  4366. 056700 040-LOAD-REC.
  4367. 056800     IF REC-KEY-D7 = 0      OR 6 OR 7
  4368. 056900         MOVE FDR-D7 TO REC-KEY0 REC-KEY6 REC-KEY7.
  4369. 057000     IF REC-KEY-D7 = 5
  4370. 057100         MOVE FDR-D7 TO REC-KEY5.
  4371. 057200 050-CNTL-CHK.
  4372. 057300     IF SWAT-CNTL-D7 NOT EQUAL SWAT-CNTL-HLD
  4373. 057400*        ADD 1 TO SPEC-TEST-CNT
  4374. 057500         MOVE 1 TO SWAT-SW
  4375. 057600         GO TO 058-CHK-CAL-SW.
  4376. 057700     IF SPECIES-D7 NOT EQUAL SPECIES-CD-SCH
  4377. 057800*        ADD 1 TO SPEC-TEST-CNT
  4378. 057900         MOVE 1 TO SPEC-SW
  4379. 058000         GO TO 058-CHK-CAL-SW.
  4380. 058100     IF REC-KEY-D7 NOT EQUAL REC-KEY-SCH
  4381. 058200         MOVE 1 TO RK-SW
  4382. 058300         GO TO 060-CK-LST.
  4383. 058400     IF (REC-KEY-D7 = 0) AND
  4384. 058500        (PN-S-0-IN NOT EQUAL PN-S-0)
  4385. 058600         MOVE 1 TO RK-SW
  4386. 058700         GO TO 060-CK-LST.
  4387. 058800 055-PASS.
  4388. 058900     IF (SWAT-SCH = AUDIT-SWAT) AND (SEL-ST = ADST-CD-SCH)
  4389. 059000         AND (SPECIES-CD-SCH = AUDIT-SPEC1 OR AUDIT-SPEC2
  4390. 059100             OR AUDIT-SPEC3)
  4391. 059200         DISPLAY FDR-D7
  4392. 059300         MOVE 1 TO AUDIT  ELSE MOVE ZERO TO AUDIT.
  4393. 059400     IF REC-KEY-D7 = 0
  4394. 059500         GO TO 100-REC-0-PROC.
  4395. 059600     IF REC-KEY-D7 = 5
  4396. 059700         GO TO 200-REC-5-PROC.
  4397. 059800     IF REC-KEY-D7 = 6
  4398. 059900         GO TO 300-REC-6-PROC.
  4399. 060000     IF REC-KEY-D7 = 7
  4400. 060100         GO TO 400-REC-7-PROC.
  4401. 060200     DISPLAY "BAD REC-KEY".
  4402. 060300     STOP RUN.
  4403. 060400 058-CHK-CAL-SW.
  4404. 060500     IF (REC-KEY-SCH = 0)
  4405. 060600         OR (SPEC-SW = 1)
  4406. 060700         OR (SWAT-SW = 1)
  4407. 060800         PERFORM 110-CAL-0-PROC THRU 110-EXIT
  4408. 060900         PERFORM 210-CAL-5-PROC THRU 210-EXIT
  4409. 061000         PERFORM 310-CAL-6-PROC THRU 310-EXIT.
  4410. 061100     IF REC-KEY-SCH = 5
  4411. 061200         PERFORM 210-CAL-5-PROC THRU 210-EXIT
  4412. 061300         PERFORM 310-CAL-6-PROC THRU 310-EXIT.
  4413. 061400     IF REC-KEY-SCH = 6
  4414. 061500         PERFORM 310-CAL-6-PROC THRU 310-EXIT.
  4415. 061600     GO TO 410-CAL-7-PROC.
  4416. 061700 060-CK-LST.
  4417. 061800     IF REC-KEY-SCH = 0
  4418. 061900         PERFORM 110-CAL-0-PROC THRU 110-EXIT
  4419. 062000         GO TO 025-CK-SUM.
  4420. 062100     IF REC-KEY-SCH = 5
  4421. 062200         PERFORM 210-CAL-5-PROC THRU 210-EXIT
  4422. 062300         GO TO 025-CK-SUM.
  4423. 062400     IF REC-KEY-SCH = 6
  4424. 062500         PERFORM 310-CAL-6-PROC THRU 310-EXIT
  4425. 062600         GO TO 025-CK-SUM.
  4426. 062700     IF REC-KEY-SCH = 7
  4427. 062800         DISPLAY "BAD SEQUENCE "
  4428. 062900         STOP RUN.
  4429. 063000 100-REC-0-PROC.
  4430. 063100     ADD 1 TO SUB1.
  4431. 063200     MOVE CHARZD-NUM-RK0 TO CHAR-TAB (SUB1).
  4432. 063300     MOVE PLANT-TYP-RK0 TO TYPE-SPEC-HLD.
  4433. 063400     MOVE PLANT-CD-RK0 TO SPEC-HLD.
  4434. 063500     MOVE TAB-KEY-0 TO TK-TAB (SUB1).
  4435. 063600     ADD CHARZD-NUM-RK0 TO PC-CHAR.
  4436. 063700     ADD CHARZD-NOT-NUM-RK0 TO PC-NOT-CHAR.
  4437. 063800     PERFORM 020-RD-IN.
  4438. 063900     GO TO 040-LOAD-REC.
  4439. 064000 110-CAL-0-PROC.
  4440. 064100     MOVE ZERO TO SUB1.
  4441. 064200     ADD PC-CHAR PC-NOT-CHAR GIVING PC-TOT-PLANTS.
  4442. 064300     IF AUDIT  = 1
  4443. 064400         MOVE 110 TO PAR-DR
  4444. 064500         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4445. 064600         MOVE "PC-CHAR" TO FAN-DR
  4446. 064700         MOVE PC-CHAR  TO FA-DR
  4447. 064800         MOVE "+" TO SGN-DR
  4448. 064900         MOVE " = " TO FILLER-DR
  4449. 065000         MOVE PC-NOT-CHAR TO FB-DR
  4450. 065100         MOVE "PC-NOT-CHAR" TO FBN-DR
  4451. 065200         MOVE PC-TOT-PLANTS TO FC-DR
  4452. 065300         MOVE "PC-TOT-PLANTS" TO FCN-DR
  4453. 065400         DISPLAY P-SPACE
  4454. 065500         DISPLAY DIS-REC.
  4455. 065600 120-LP-TB.
  4456. 065700     ADD 1 TO SUB1.
  4457. 065800     IF TK-TAB (SUB1) = ZERO
  4458. 065900         MOVE ZERO TO SUB1
  4459. 066000         INITIALIZE PLANT-CAL-TABLE PLANT-CAL-HLD
  4460. 066100         GO TO 110-EXIT.
  4461. 066200     MOVE TK-TAB (SUB1) TO PC-TABKEY.
  4462. 066300     DIVIDE PC-CHAR INTO CHAR-TAB (SUB1)
  4463. 066400         GIVING PC-PCT.
  4464. 066500     IF AUDIT  = 1
  4465. 066600         MOVE 120 TO PAR-DR
  4466. 066700         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4467. 066800         MOVE "PC-CHAR" TO FAN-DR
  4468. 066900         MOVE PC-CHAR TO FA-DR
  4469. 067000         MOVE "/" TO SGN-DR
  4470. 067100         MOVE CHAR-TAB (SUB1) TO FB-DR
  4471. 067200         MOVE "CHAR-TAB (SUB1)" TO FBN-DR
  4472. 067300         MOVE PC-PCT TO FC2-DR
  4473. 067400         MOVE "PC-PCT" TO FCN-DR
  4474. 067500         MOVE "(  ) " TO PR2-DR
  4475. 067600         MOVE SUB1 TO SB2-DR
  4476. 067700         DISPLAY P-SPACE
  4477. 067800         DISPLAY DIS-REC.
  4478. 067900     MULTIPLY PC-PCT BY PC-TOT-PLANTS
  4479. 068000         GIVING TOT-PLANTS (PC-TABKEY) ROUNDED.
  4480. 068100     IF AUDIT  = 1
  4481. 068200         MOVE 121 TO PAR-DR
  4482. 068300         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4483. 068400         MOVE "PC-PCT" TO FAN-DR
  4484. 068500         MOVE PC-PCT TO FA2-DR
  4485. 068600         MOVE "X" TO SGN-DR
  4486. 068700         MOVE PC-TOT-PLANTS TO FB-DR
  4487. 068800         MOVE "PC-TOT-PLANTS" TO FBN-DR
  4488. 068900         MOVE TOT-PLANTS (PC-TABKEY) TO FC-DR
  4489. 069000         MOVE "TOT-PLANTS (PC-TABKEY)" TO FCN-DR
  4490. 069100         MOVE "(  ) " TO PR3-DR
  4491. 069200         MOVE PC-TABKEY TO SB3-DR
  4492. 069300         DISPLAY P-SPACE
  4493. 069400         DISPLAY DIS-REC.
  4494. 069500     ADD TOT-PLANTS (PC-TABKEY) TO PLANT-TOTAL.
  4495. 069600     IF AUDIT  = 1
  4496. 069700         MOVE 122 TO PAR-DR
  4497. 069800         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4498. 069900         MOVE "TOT-PLANTS (PC-TABKEY)" TO FAN-DR
  4499. 070000         MOVE TOT-PLANTS (PC-TABKEY) TO FA-DR
  4500. 070100         MOVE "+" TO SGN-DR
  4501. 070200         MOVE " = " TO FILLER-DR
  4502. 070300         MOVE SPACE TO FBS-DR
  4503. 070400         MOVE SPACE TO FBN-DR
  4504. 070500         MOVE PLANT-TOTAL TO FC-DR
  4505. 070600         MOVE "PLANT-TOTAL" TO FCN-DR
  4506. 070700         MOVE "(  ) " TO PR1-DR
  4507. 070800         MOVE PC-TABKEY TO SB1-DR
  4508. 070900         DISPLAY P-SPACE
  4509. 071000         DISPLAY DIS-REC.
  4510. 071100     GO TO 120-LP-TB.
  4511. 071200 200-REC-5-PROC.
  4512. 071300     MOVE PLANT-TYP-RK5 TO TYPE-SPEC-HLD.
  4513. 071400     MOVE PLANT-CD-RK5 TO SPEC-HLD.
  4514. 071500     MOVE ZERO TO SUB5.
  4515. 071600     MOVE PLOT-SIZ-EST-RK5 TO PW-SIZE PLOT-SAMP-SZ-FAH.
  4516. 071700     MOVE PLOT-TOT-NUM-RK5 TO PW-PLOT-TOT.
  4517. 071800     MOVE HGT-CLS-CD-RK5 TO HC-HLD.
  4518. 071900     IF HC-HLD < 1 OR > 4
  4519. 072000         MOVE 1 TO HC-HLD.
  4520. 072100     IF FMT-NUM-RK5 = 1 MOVE ZERO TO SUB6.
  4521. 072200     IF FMT-NUM-RK5 = 2 MOVE 10 TO SUB6.
  4522. 072300     IF FMT-NUM-RK5 = 3 MOVE 20 TO SUB6.
  4523. 072400     IF FMT-NUM-RK5 = 4 MOVE 30 TO SUB6.
  4524. 072500 205-LP-TB.
  4525. 072600     IF SUB5 = 10 PERFORM 020-RD-IN GO TO 040-LOAD-REC.
  4526. 072700     ADD 1 TO SUB5.
  4527. 072800     ADD 1 TO SUB6.
  4528. 072900*    IF HRBG-PROD-WGT-RK5 (SUB5) > ZERO
  4529. 073000*        ADD HRBG-PROD-WGT-RK5 (SUB5) TO GRAM-UP-TB (SUB6)
  4530. 073100*        ADD HRBG-PROD-WGT-RK5 (SUB5) TO
  4531. 073200*            GRAM-HC-TB (HC-HLD).
  4532. 073300*        ADD 1 TO PLOT-TOT-HC-TB (HC-HLD).
  4533. 073400*    MOVE CLS-PLANT-UTIL-RK5 (SUB5) TO UTIL-HLD.
  4534. 073500*    MOVE PHNO-STG-RK5 (SUB5) TO PHNO-HLD.
  4535. 073600*    IF UTIL-TB (SUB6) = ZERO
  4536. 073700*        MOVE UTIL-HLD TO UTIL-TB (SUB6).
  4537. 073800*    IF PHNO-TB (SUB6) = ZERO
  4538. 073900*        MOVE PHNO-HLD TO PHNO-TB (SUB6).
  4539. 074000*    IF UTIL-HLD > ZERO
  4540. 074100*        MOVE MID-PT (UTIL-HLD) TO MID-PT-TB (SUB6)
  4541. 074200*        ELSE MOVE ZERO TO MID-PT-TB (SUB6).
  4542. 074300*    GO TO 205-LP-TB.
  4543. 074400     MOVE CLS-PLANT-UTIL-RK5 (SUB5) TO UTIL-HLD.
  4544. 074500     MOVE PHNO-STG-RK5 (SUB5) TO PHNO-HLD.
  4545. 074600     IF (PHNO-STG-RK5 (SUB5) > ZERO)
  4546. 074700         ADD 1 TO PHNO-PLOT-TOT
  4547. 074800         MOVE PHNO-HLD TO PHNO-TAB (SUB6) .
  4548. 074900     IF (HRBG-PROD-WGT-RK5 (SUB5) > ZERO)
  4549. 075000         MOVE 1 TO AVAIL-SW
  4550. 075100         ADD HRBG-PROD-WGT-RK5 (SUB5) TO
  4551. 075200             GRAM-HC-TB (HC-HLD).
  4552. 075300     IF (HRBG-PROD-WGT-RK5 (SUB5) > ZERO)
  4553. 075400         AND (PHNO-STG-RK5 (SUB5) > ZERO)
  4554. 075500         ADD HRBG-PROD-WGT-RK5 (SUB5) TO GRAM-UP-TB (SUB6)
  4555. 075600         MOVE UTIL-HLD TO UTIL-TB (SUB6)
  4556. 075700         MOVE PHNO-HLD TO PHNO-TB (SUB6)
  4557. 075800             ELSE GO TO 205-LP-TB.
  4558. 075900     IF UTIL-HLD > ZERO
  4559. 076000         MOVE MID-PT (UTIL-HLD) TO MID-PT-TB (SUB6)
  4560. 076100         ELSE MOVE ZERO TO MID-PT-TB (SUB6).
  4561. 076200     MOVE ZERO TO AVAIL-TB (SUB6).
  4562. 076300     IF CLS-PLANT-AVAIL-RK5 (SUB5) = " " OR "A"
  4563. 076400         MOVE 1.00 TO AVAIL-TB (SUB6).
  4564. 076500*    IF CLS-PLANT-AVAIL-RK5 (SUB5) = "P"
  4565. 076600*       MOVE 0.50 TO AVAIL-TB (SUB6).
  4566. 076700     IF CLS-PLANT-AVAIL-RK5 (SUB5) = "U"
  4567. 076800        MOVE 0.00 TO AVAIL-TB (SUB6).
  4568. 076900     IF CLS-PLANT-AVAIL-RK5 (SUB5) = "P"
  4569. 077000         MOVE 0.75 TO AVAIL-TB (SUB6).
  4570. 077100     IF CLS-PLANT-AVAIL-RK5 (SUB5) = "H"
  4571. 077200         MOVE 0.50 TO AVAIL-TB (SUB6).
  4572. 077300     IF CLS-PLANT-AVAIL-RK5 (SUB5) = "L"
  4573. 077400         MOVE 0.25 TO AVAIL-TB (SUB6).
  4574. 077500     GO TO 205-LP-TB.
  4575. 077600 110-EXIT.
  4576. 077700     EXIT.
  4577. 077800 210-CAL-5-PROC.
  4578. 077900     MOVE ZERO TO SUB6 UTIL-AVG PHNO-AVG.
  4579. 078000 230-LP-TB.
  4580. 078100     ADD 1 TO SUB6.
  4581. 078200     IF SUB6 < 41
  4582. 078300          GO TO 240-UTIL-PHENO.
  4583. 078400     IF (PHNO-GRAMS-TOT > ZERO) AND (AVG-AVAIL-TOT > ZERO)
  4584. 078500         DIVIDE PHNO-GRAMS-TOT INTO AVG-AVAIL-TOT
  4585. 078600         GIVING AVG-AVAIL ROUNDED.
  4586. 078700     IF PHNO-AVG-PLOT-TOT > ZERO
  4587. 078800         DIVIDE PHNO-PLOT-TOT INTO PHNO-AVG-PLOT-TOT
  4588. 078900             GIVING PHNO-PLOT-AVG ROUNDED.
  4589. 079000     IF AUDIT  = 1 GO TO 235-UP-DISPLAY.
  4590. 079100     IF UTIL-MID-POINT-TOT > ZERO
  4591. 079200         DIVIDE UTIL-GRAMS-TOT INTO UTIL-MID-POINT-TOT
  4592. 079300             GIVING UTIL-AVG ROUNDED.
  4593. 079400     IF PHNO-AVG-TOT > ZERO
  4594. 079500         DIVIDE PHNO-GRAMS-TOT INTO PHNO-AVG-TOT
  4595. 079600             GIVING PHNO-AVG ROUNDED.
  4596. 079700     GO TO 245-CLEAR.
  4597. 079800 235-UP-DISPLAY.
  4598. 079900     IF (PHNO-GRAMS-TOT > ZERO) AND (AVG-AVAIL-TOT > ZERO)
  4599. 080000         AND (AUDIT  = 1)
  4600. 080100         MOVE 229 TO PAR-DR
  4601. 080200         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4602. 080300         MOVE "PHNO-GRAMS-TOT" TO FAN-DR
  4603. 080400         MOVE  PHNO-GRAMS-TOT  TO FA1-DR
  4604. 080500         MOVE "/" TO SGN-DR
  4605. 080600         MOVE AVG-AVAIL-TOT TO FB1-DR
  4606. 080700         MOVE "AVG-AVAIL-TOT" TO FBN-DR
  4607. 080800         MOVE AVG-AVAIL TO FC2-DR
  4608. 080900         MOVE "AVG-AVAIL" TO FCN-DR
  4609. 081000         DISPLAY P-SPACE
  4610. 081100         DISPLAY DIS-REC.
  4611. 081200     IF UTIL-MID-POINT-TOT > ZERO
  4612. 081300         DIVIDE UTIL-GRAMS-TOT INTO UTIL-MID-POINT-TOT
  4613. 081400             GIVING UTIL-AVG ROUNDED
  4614. 081500         MOVE 230 TO PAR-DR
  4615. 081600         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4616. 081700         MOVE "UTIL-GRAMS-TOT" TO FAN-DR
  4617. 081800         MOVE UTIL-GRAMS-TOT TO FA-DR
  4618. 081900         MOVE "/" TO SGN-DR
  4619. 082000         MOVE UTIL-MID-POINT-TOT TO FB3-DR
  4620. 082100         MOVE "UTIL-MID-POINT-TOT" TO FBN-DR
  4621. 082200         MOVE UTIL-AVG TO FC2-DR
  4622. 082300         MOVE "UTIL-AVG" TO FCN-DR
  4623. 082400         DISPLAY P-SPACE
  4624. 082500         DISPLAY DIS-REC.
  4625. 082600     IF PHNO-AVG-TOT > ZERO
  4626. 082700         DIVIDE PHNO-GRAMS-TOT INTO PHNO-AVG-TOT
  4627. 082800             GIVING PHNO-AVG ROUNDED
  4628. 082900         MOVE 231 TO PAR-DR
  4629. 083000         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4630. 083100         MOVE "PHNO-GRAMS-TOT" TO FAN-DR
  4631. 083200         MOVE PHNO-GRAMS-TOT TO FA-DR
  4632. 083300         MOVE "/" TO SGN-DR
  4633. 083400         MOVE PHNO-AVG-TOT TO FB-DR
  4634. 083500         MOVE "PHNO-AVG-TOT" TO FBN-DR
  4635. 083600         MOVE PHNO-AVG TO FC-DR
  4636. 083700         MOVE "PHNO-AVG" TO FCN-DR
  4637. 083800         DISPLAY P-SPACE
  4638. 083900         DISPLAY DIS-REC
  4639. 084000         GO TO 245-CLEAR.
  4640. 084100 240-UTIL-PHENO.
  4641. 084200     MOVE MID-PT-TB (SUB6) TO MID-PT-HLD.
  4642. 084300     IF (GRAM-UP-TB (SUB6) > ZERO) AND (AUDIT  = ZERO)
  4643. 084400         AND (PHNO-TB (SUB6) > ZERO)
  4644. 084500         ADD GRAM-UP-TB (SUB6) TO UTIL-GRAMS-TOT.
  4645. 084600     IF (GRAM-UP-TB (SUB6) > ZERO) AND (AUDIT  = 1)
  4646. 084700         AND (PHNO-TB (SUB6) > ZERO)
  4647. 084800         ADD GRAM-UP-TB (SUB6) TO UTIL-GRAMS-TOT
  4648. 084900         MOVE 232 TO PAR-DR
  4649. 085000         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4650. 085100         MOVE "GRAM-UP-TAB (SUB6)" TO FAN-DR
  4651. 085200         MOVE GRAM-UP-TB (SUB6) TO FA-DR
  4652. 085300         MOVE "+" TO SGN-DR
  4653. 085400         MOVE " = " TO FILLER-DR
  4654. 085500         MOVE SPACE TO FBS-DR
  4655. 085600         MOVE SPACE TO FBN-DR
  4656. 085700         MOVE UTIL-GRAMS-TOT TO FC-DR
  4657. 085800         MOVE "UTIL-GRAMS-TOT" TO FCN-DR
  4658. 085900         MOVE "(  ) " TO PR1-DR
  4659. 086000         MOVE SUB6 TO SB1-DR
  4660. 086100         DISPLAY P-SPACE
  4661. 086200         DISPLAY DIS-REC.
  4662. 086300     IF (MID-PT-TB (SUB6) > ZERO) AND
  4663. 086400        (GRAM-UP-TB (SUB6) > ZERO)
  4664. 086500         MULTIPLY MID-PT-HLD-RD BY GRAM-UP-TB (SUB6)
  4665. 086600             GIVING UTIL-MP-ACUM
  4666. 086700             ADD UTIL-MP-ACUM TO UTIL-MID-POINT-TOT.
  4667. 086800     IF (MID-PT-TB (SUB6) > ZERO) AND
  4668. 086900        (GRAM-UP-TB (SUB6) > ZERO)
  4669. 087000         AND (AUDIT  = 1)
  4670. 087100         MOVE 233 TO PAR-DR
  4671. 087200         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4672. 087300         MOVE "MID-PT-HLD-RD" TO FAN-DR
  4673. 087400         MOVE MID-PT-HLD-RD TO FA2-DR
  4674. 087500         MOVE "X" TO SGN-DR
  4675. 087600         MOVE GRAM-UP-TB (SUB6) TO FB-DR
  4676. 087700         MOVE "GRAM-UP-TB (SUB6)" TO FBN-DR
  4677. 087800         MOVE UTIL-MP-ACUM TO FC3-DR
  4678. 087900         MOVE "UTIL-MP-ACUM" TO FCN-DR
  4679. 088000         MOVE "(  ) " TO PR2-DR
  4680. 088100         MOVE SUB6 TO SB2-DR
  4681. 088200         DISPLAY P-SPACE
  4682. 088300         DISPLAY DIS-REC
  4683. 088400         MOVE 234 TO PAR-DR
  4684. 088500         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4685. 088600         MOVE "UTIL-MP-ACUM" TO FAN-DR
  4686. 088700         MOVE UTIL-MP-ACUM TO FA3-DR
  4687. 088800         MOVE "+" TO SGN-DR
  4688. 088900         MOVE " = " TO FILLER-DR
  4689. 089000         MOVE SPACE TO FBS-DR
  4690. 089100         MOVE SPACE TO FBN-DR
  4691. 089200         MOVE UTIL-MID-POINT-TOT TO FC3-DR
  4692. 089300         MOVE "UTIL-MID-POINT-TOT" TO FCN-DR
  4693. 089400         DISPLAY P-SPACE
  4694. 089500         DISPLAY DIS-REC.
  4695. 089600     IF PHNO-TAB (SUB6) > ZERO
  4696. 089700         ADD PHNO-TAB (SUB6) TO PHNO-AVG-PLOT-TOT.
  4697. 089800     IF PHNO-TB (SUB6) > ZERO
  4698. 089900         ADD GRAM-UP-TB (SUB6) TO PHNO-GRAMS-TOT.
  4699. 090000     IF (PHNO-TB (SUB6) > ZERO) AND
  4700. 090100        (GRAM-UP-TB (SUB6) > ZERO)
  4701. 090200         MULTIPLY PHNO-TB (SUB6) BY GRAM-UP-TB (SUB6)
  4702. 090300         GIVING PHNO-ACUM
  4703. 090400         ADD PHNO-ACUM TO PHNO-AVG-TOT.
  4704. 090500     IF (PHNO-TB (SUB6) > ZERO) AND
  4705. 090600        (GRAM-UP-TB (SUB6) > ZERO) AND (AUDIT  = 1)
  4706. 090700         MOVE 235 TO PAR-DR
  4707. 090800         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4708. 090900         MOVE "PHNO-TB (SUB6)" TO FAN-DR
  4709. 091000         MOVE PHNO-TB (SUB6) TO FA-DR
  4710. 091100         MOVE "X" TO SGN-DR
  4711. 091200         MOVE GRAM-UP-TB (SUB6) TO FB-DR
  4712. 091300         MOVE "GRAM-UP-TB (SUB6)" TO FBN-DR
  4713. 091400         MOVE PHNO-ACUM TO FC-DR
  4714. 091500         MOVE "PHNO-ACUM" TO FCN-DR
  4715. 091600         MOVE "(  ) " TO PR2-DR
  4716. 091700         MOVE SUB6 TO SB2-DR
  4717. 091800         DISPLAY P-SPACE
  4718. 091900         DISPLAY DIS-REC.
  4719. 092000     IF (PHNO-TB (SUB6) > ZERO) AND
  4720. 092100         (GRAM-UP-TB (SUB6) > ZERO)
  4721. 092200         NEXT SENTENCE ELSE
  4722. 092300         GO TO 230-LP-TB.
  4723. 092400     MOVE AVAIL-TB (SUB6) TO AVG-AVAIL-PCT.
  4724. 092500     MOVE GRAM-UP-TB (SUB6) TO GRAM-UP-TB-HLD.
  4725. 092600     MULTIPLY AVG-AVAIL-PCT BY GRAM-UP-TB-HLD
  4726. 092700             GIVING AVG-AVAIL-SUM.
  4727. 092800     ADD AVG-AVAIL-SUM TO AVG-AVAIL-TOT.
  4728. 092900     IF (AUDIT = 1)
  4729. 093000         MOVE 236 TO PAR-DR
  4730. 093100         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4731. 093200         MOVE "AVAIL-TB (SUB6)" TO FAN-DR
  4732. 093300         MOVE AVAIL-TB (SUB6) TO FA2-DR
  4733. 093400         MOVE "X" TO SGN-DR
  4734. 093500         MOVE GRAM-UP-TB (SUB6) TO FB1-DR
  4735. 093600         MOVE "GRAM-UP-TB (SUB6)" TO FBN-DR
  4736. 093700         MOVE AVG-AVAIL-SUM TO FC1-DR
  4737. 093800         MOVE "AVG-AVAIL-SUM" TO FCN-DR
  4738. 093900         MOVE "(  ) " TO PR2-DR
  4739. 094000         MOVE SUB6 TO SB2-DR
  4740. 094100         DISPLAY P-SPACE
  4741. 094200         DISPLAY DIS-REC.
  4742. 094300     GO TO 230-LP-TB.
  4743. 094400 245-CLEAR.
  4744. 094500     INITIALIZE UTIL-PHENO-TABLE SUB5 SUB6.
  4745. 094600 210-EXIT.
  4746. 094700     EXIT.
  4747. 094800 300-REC-6-PROC.
  4748. 094900     MOVE PLANT-TYP-RK6 TO TYPE-SPEC-HLD.
  4749. 095000     IF PLOT-SIZE-RK6 = 1
  4750. 095100         MOVE 100 TO ACRE-FRAC-FAH ELSE
  4751. 095200         MOVE 200 TO ACRE-FRAC-FAH.
  4752. 095300     MOVE FORM-CLS-KEY-6 TO FC-KEY.
  4753. 095400     IF PW-PLOT-TOT = ZERO MOVE 10 TO PW-PLOT-TOT.
  4754. 095500     MOVE PLOTS-CHRZ-HLD TO PLOT-TOT-FC-TB (FC-KEY).
  4755. 095600     IF FORM-CLS-KEY-6 < 1 OR > 5
  4756. 095700         MOVE 6 TO FORM-CLS-KEY-6 FC-KEY.
  4757. 095800     MOVE TOT-PLANTS (TAB-KEY-0) TO PLANT-TOT-HLD.
  4758. 095900*    IF FAC-IN NOT = FAC-HLD
  4759. 096000*        ADD 1 TO PLOT-TOT-FC-TB (FC-KEY).
  4760. 096100     ADD PLANT-TOT-HLD TO PLANT-TOT-FC-TB (FC-KEY).
  4761. 096200     IF AUDIT  = 1
  4762. 096300         MOVE 300 TO PAR-DR
  4763. 096400         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4764. 096500         MOVE "PLANT-TOT-HLD" TO FAN-DR
  4765. 096600         MOVE PLANT-TOT-HLD TO FA-DR
  4766. 096700         MOVE "+" TO SGN-DR
  4767. 096800         MOVE " = " TO FILLER-DR
  4768. 096900         MOVE SPACE TO FBS-DR
  4769. 097000         MOVE SPACE TO FBN-DR
  4770. 097100         MOVE PLANT-TOT-FC-TB (FC-KEY) TO FC-DR
  4771. 097200         MOVE "PLANT-TOT-FC-TB (FC-KEY)" TO FCN-DR
  4772. 097300         MOVE "(  ) " TO PR3-DR
  4773. 097400         MOVE FC-KEY TO SB3-DR
  4774. 097500         DISPLAY P-SPACE
  4775. 097600         DISPLAY DIS-REC.
  4776. 097700     PERFORM 020-RD-IN.
  4777. 097800     GO TO 040-LOAD-REC.
  4778. 097900 310-CAL-6-PROC.
  4779. 098000     MOVE ZERO TO SUB4.
  4780. 098100 320-LP-TB.
  4781. 098200     ADD 1 TO SUB4.
  4782. 098300     IF SUB4 = 7
  4783. 098400         MOVE ZERO TO SUB4
  4784. 098500         GO TO 310-EXIT.
  4785. 098600     IF (PLANT-TOT-FC-TB (SUB4) = ZERO)
  4786. 098700         GO TO 320-LP-TB.
  4787. 098800     IF TYPE-SPEC-HLD = "T" OR "S"
  4788. 098900         MULTIPLY ACRE-FRAC-FAH BY PLANT-TOT-FC-TB (SUB4)
  4789. 099000         GIVING PLANTS-ACUM
  4790. 099100         DIVIDE PLOT-TOT-FC-TB (SUB4) INTO PLANTS-ACUM
  4791. 099200             GIVING PIA-FC (SUB4) ROUNDED.
  4792. 099300     IF (TYPE-SPEC-HLD = "T" OR "S")
  4793. 099400         AND (AUDIT  = 1)
  4794. 099500         MOVE 320 TO PAR-DR
  4795. 099600         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4796. 099700         MOVE "ACRE-FRAC-FAH" TO FAN-DR
  4797. 099800         MOVE ACRE-FRAC-FAH TO FA-DR
  4798. 099900         MOVE "X" TO SGN-DR
  4799. 100000         MOVE PLANT-TOT-FC-TB (SUB4) TO FB-DR
  4800. 100100         MOVE "PLANT-TOT-FC-TB (SUB4)" TO FBN-DR
  4801. 100200         MOVE PLANTS-ACUM TO FC-DR
  4802. 100300         MOVE "PLANTS-ACUM" TO FCN-DR
  4803. 100400         DISPLAY P-SPACE
  4804. 100500         DISPLAY DIS-REC
  4805. 100600         MOVE 320 TO PAR-DR
  4806. 100700         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4807. 100800         MOVE "PLOT-TOT-FC-TB (SUB4)" TO FAN-DR
  4808. 100900         MOVE PLOT-TOT-FC-TB (SUB4) TO FA-DR
  4809. 101000         MOVE "/" TO SGN-DR
  4810. 101100         MOVE PLANTS-ACUM TO FB-DR
  4811. 101200         MOVE "PLANTS-ACUM" TO FBN-DR
  4812. 101300         MOVE PIA-FC (SUB4) TO FC-DR
  4813. 101400         MOVE "PIA-FC (SUB4)" TO FCN-DR
  4814. 101500         MOVE "(  ) " TO PR1-DR
  4815. 101600         MOVE SUB4 TO SB1-DR
  4816. 101700         MOVE "(  ) " TO PR3-DR
  4817. 101800         MOVE SUB4 TO SB3-DR
  4818. 101900         DISPLAY P-SPACE
  4819. 102000         DISPLAY DIS-REC.
  4820. 102100     IF (TYPE-SPEC-HLD = "G" OR "F")
  4821. 102200         AND (PLOT-SAMP-SZ-FAH = ZERO)
  4822. 102300             IF PLOT-SIZE-0 = 1 MOVE 435.60 TO PLOT-SAMP-SZ-FAH
  4823. 102400                 ELSE
  4824. 102500             IF PLOT-SIZE-0 = 2 MOVE 217.80 TO PLOT-SAMP-SZ-FAH.
  4825. 102600     IF TYPE-SPEC-HLD = "G" OR "F"
  4826. 102700         MULTIPLY PLOT-TOT-FC-TB (SUB4) BY PLOT-SAMP-SZ-FAH
  4827. 102800             GIVING ACRE-SF-TOT
  4828. 102900         MULTIPLY 43560 BY PLANT-TOT-FC-TB (SUB4)
  4829. 103000             GIVING PLANTS-ACUM
  4830. 103100         DIVIDE ACRE-SF-TOT INTO PLANTS-ACUM
  4831. 103200             GIVING PIA-FC (SUB4) ROUNDED.
  4832. 103300     IF (TYPE-SPEC-HLD = "G" OR "F")
  4833. 103400         AND (AUDIT  = 1)
  4834. 103500         MOVE 320 TO PAR-DR
  4835. 103600         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4836. 103700         MOVE "PLOT-TOT-FC-TB (SUB4)" TO FAN-DR
  4837. 103800         MOVE PLOT-TOT-FC-TB (SUB4) TO FA-DR
  4838. 103900         MOVE "X" TO SGN-DR
  4839. 104000         MOVE PLOT-SAMP-SZ-FAH TO FB2-DR
  4840. 104100         MOVE "PLOT-SAMP-SZ-FAH" TO FBN-DR
  4841. 104200         MOVE ACRE-SF-TOT TO FC1-DR
  4842. 104300         MOVE "ACRE-SF-TOT" TO FCN-DR
  4843. 104400         MOVE "(  ) " TO PR1-DR
  4844. 104500         MOVE SUB4 TO SB1-DR
  4845. 104600         DISPLAY P-SPACE
  4846. 104700         DISPLAY DIS-REC
  4847. 104800         MOVE 322 TO PAR-DR
  4848. 104900         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4849. 105000         MOVE "CONSTANT" TO FAN-DR
  4850. 105100         MOVE 43560 TO FA-DR
  4851. 105200         MOVE "X" TO SGN-DR
  4852. 105300         MOVE PLANT-TOT-FC-TB (SUB4) TO FB-DR
  4853. 105400         MOVE "PLANT-TOT-FC-TB (SUB4)" TO FBN-DR
  4854. 105500         MOVE  PLANTS-ACUM  TO FC-DR
  4855. 105600         MOVE "PLANTS-ACUM" TO FCN-DR
  4856. 105700         MOVE "(  ) " TO PR2-DR
  4857. 105800         MOVE SUB4 TO SB2-DR
  4858. 105900         DISPLAY P-SPACE
  4859. 106000         DISPLAY DIS-REC
  4860. 106100         MOVE 323 TO PAR-DR
  4861. 106200         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4862. 106300         MOVE "ACRE-SF-TOT" TO FAN-DR
  4863. 106400         MOVE ACRE-SF-TOT TO FA1-DR
  4864. 106500         MOVE "/" TO SGN-DR
  4865. 106600         MOVE PLANTS-ACUM TO FB-DR
  4866. 106700         MOVE "PLANTS-ACUM" TO FBN-DR
  4867. 106800         MOVE PIA-FC (SUB4) TO FC-DR
  4868. 106900         MOVE "PIA-FC (SUB4)" TO FCN-DR
  4869. 107000         MOVE "(  ) " TO PR3-DR
  4870. 107100         MOVE SUB4 TO SB3-DR
  4871. 107200         DISPLAY P-SPACE
  4872. 107300         DISPLAY DIS-REC.
  4873. 107400     GO TO 320-LP-TB.
  4874. 107500 310-EXIT.
  4875. 107600     EXIT.
  4876. 107700 400-REC-7-PROC.
  4877. 107800     MOVE PLANT-TYP-RK7 TO TYPE-SPEC-HLD.
  4878. 107900     IF PLOT-SIZE-RK7 = 1
  4879. 108000         MOVE 100 TO ACRE-FRAC-FAH ELSE
  4880. 108100         MOVE 200 TO ACRE-FRAC-FAH.
  4881. 108200     MOVE 8 TO AGE.
  4882. 108300     IF AGE-CLS-PLANT-RK0 = "S" MOVE 1 TO AGE.
  4883. 108400     IF AGE-CLS-PLANT-RK0 = "P" MOVE 2 TO AGE.
  4884. 108500     IF AGE-CLS-PLANT-RK0 = "Y" MOVE 3 TO AGE.
  4885. 108600     IF AGE-CLS-PLANT-RK0 = "M" MOVE 4 TO AGE.
  4886. 108700     IF AGE-CLS-PLANT-RK0 = "O" MOVE 5 TO AGE.
  4887. 108800     IF AGE-CLS-PLANT-RK0 = "D" MOVE 6 TO AGE.
  4888. 108900     IF AGE-CLS-PLANT-RK0 = "R" MOVE 7 TO AGE.
  4889. 109000     MOVE TOT-PLANTS (TAB-KEY-0) TO PLANT-TOT-HLD.
  4890. 109100     IF PW-PLOT-TOT = ZERO MOVE 10 TO PW-PLOT-TOT.
  4891. 109200     MOVE PLOTS-CHRZ-HLD TO PLOT-TOT-AC-TB (AGE).
  4892. 109300*    IF FAC-IN NOT = FAC-HLD
  4893. 109400*        ADD 1 TO PLOT-TOT-AC-TB (AGE).
  4894. 109500     ADD PLANT-TOT-HLD TO PLANT-TOT-AC-TB (AGE).
  4895. 109600     ADD PLANT-TOT-HLD TO PLANT-TOT-HGT.
  4896. 109700*    IF TYPE-SPEC-HLD = "G" OR "F"
  4897. 109800*        ADD PLANT-TOT-HLD TO PLANT-TOT-AVAIL.
  4898. 109900     IF TYPE-SPEC-HLD = "T" OR "S"
  4899. 110000         ADD PLANT-TOT-HLD TO PLANT-TOT-CROWN.
  4900. 110100     IF (AVG-HGT-PLANT-RK0 > ZERO) AND PLANT-TOT-HLD > ZERO
  4901. 110200         MULTIPLY PLANT-TOT-HLD BY AVG-HGT-PLANT-RK0
  4902. 110300             GIVING AVG-HGT-SUM
  4903. 110400         ADD AVG-HGT-SUM TO AVG-HGT-TOT.
  4904. 110500     IF (AVG-HGT-PLANT-RK0 > ZERO) AND (PLANT-TOT-HLD > ZERO)
  4905. 110600         AND (AUDIT  = 1)
  4906. 110700         MOVE 400 TO PAR-DR
  4907. 110800         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4908. 110900         MOVE "PLANT-TOT-HLD" TO FAN-DR
  4909. 111000         MOVE PLANT-TOT-HLD TO FA-DR
  4910. 111100         MOVE "X" TO SGN-DR
  4911. 111200         MOVE AVG-HGT-PLANT-RK0 TO FB1-DR
  4912. 111300         MOVE "AVG-HGT-PLANT-RK0" TO FBN-DR
  4913. 111400         MOVE AVG-HGT-SUM TO FC1-DR
  4914. 111500         MOVE "AVG-HGT-SUM" TO FCN-DR
  4915. 111600         DISPLAY P-SPACE
  4916. 111700         DISPLAY DIS-REC
  4917. 111800         MOVE 401 TO PAR-DR
  4918. 111900         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4919. 112000         MOVE "AVG-HGT-SUM" TO FAN-DR
  4920. 112100         MOVE AVG-HGT-SUM TO FA1-DR
  4921. 112200         MOVE "+" TO SGN-DR
  4922. 112300         MOVE " = " TO FILLER-DR
  4923. 112400         MOVE SPACE TO FBS-DR
  4924. 112500         MOVE SPACE TO FBN-DR
  4925. 112600         MOVE AVG-HGT-TOT TO FC1-DR
  4926. 112700         MOVE "AVG-HGT-TOT" TO FCN-DR
  4927. 112800         DISPLAY P-SPACE
  4928. 112900         DISPLAY DIS-REC.
  4929. 113000     IF (TYPE-SPEC-HLD = "T" OR "S") AND
  4930. 113100         (AVG-CROWN-DIA-RK0 > ZERO) AND
  4931. 113200         (PLANT-TOT-HLD > ZERO)
  4932. 113300            MULTIPLY PLANT-TOT-HLD BY AVG-CROWN-DIA-RK0
  4933. 113400            GIVING AVG-CROWN-SUM
  4934. 113500            ADD AVG-CROWN-SUM TO AVG-CROWN-TOT.
  4935. 113600     IF (TYPE-SPEC-HLD = "T" OR "S") AND
  4936. 113700         (AVG-CROWN-DIA-RK0 > ZERO) AND
  4937. 113800         (PLANT-TOT-HLD > ZERO)
  4938. 113900         AND (AUDIT  = 1)
  4939. 114000         MOVE 402 TO PAR-DR
  4940. 114100         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4941. 114200         MOVE "PLANT-TOT-HLD" TO FAN-DR
  4942. 114300         MOVE PLANT-TOT-HLD TO FA-DR
  4943. 114400         MOVE "X" TO SGN-DR
  4944. 114500         MOVE AVG-CROWN-DIA-RK0 TO FB1-DR
  4945. 114600         MOVE "AVG-CROWN-DIA-RK0" TO FBN-DR
  4946. 114700         MOVE AVG-CROWN-SUM TO FC1-DR
  4947. 114800         MOVE "AVG-CROWN-SUM" TO FCN-DR
  4948. 114900         DISPLAY P-SPACE
  4949. 115000         DISPLAY DIS-REC
  4950. 115100         MOVE 402 TO PAR-DR
  4951. 115200         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4952. 115300         MOVE "AVG-CROWN-SUM" TO FAN-DR
  4953. 115400         MOVE AVG-CROWN-SUM TO FA1-DR
  4954. 115500         MOVE "+" TO SGN-DR
  4955. 115600         MOVE " = " TO FILLER-DR
  4956. 115700         MOVE SPACE TO FBS-DR
  4957. 115800         MOVE SPACE TO FBN-DR
  4958. 115900         MOVE AVG-CROWN-TOT TO FC1-DR
  4959. 116000         MOVE "AVG-CROWN-TOT" TO FCN-DR
  4960. 116100         DISPLAY P-SPACE
  4961. 116200         DISPLAY DIS-REC.
  4962. 116300*    IF TYPE-SPEC-HLD = "G" OR "F" NEXT SENTENCE
  4963. 116400*        ELSE
  4964. 116500*        PERFORM 020-RD-IN
  4965. 116600*        GO TO 040-LOAD-REC.
  4966. 116700*    IF CLS-PLANT-AVAIL-RK0 = " " OR "A"
  4967. 116800*        MOVE 1.00 TO AVG-AVAIL-PCT.
  4968. 116900*    IF CLS-PLANT-AVAIL-RK0 = "P" MOVE 0.50 TO AVG-AVAIL-PCT.
  4969. 117000*    IF CLS-PLANT-AVAIL-RK0 = "U" MOVE 0.00 TO AVG-AVAIL-PCT.
  4970. 117100*    IF CLS-PLANT-AVAIL-RK0 = "P" MOVE 0.75 TO AVG-AVAIL-PCT.
  4971. 117200*    IF CLS-PLANT-AVAIL-RK0 = "H" MOVE 0.50 TO AVG-AVAIL-PCT.
  4972. 117300*    IF CLS-PLANT-AVAIL-RK0 = "L" MOVE 0.25 TO AVG-AVAIL-PCT.
  4973. 117400*    IF (AVG-AVAIL-PCT > ZERO) AND
  4974. 117500*       (PLANT-TOT-HLD > ZERO)
  4975. 117600*        MULTIPLY AVG-AVAIL-PCT BY PLANT-TOT-HLD
  4976. 117700*            GIVING AVG-AVAIL-SUM
  4977. 117800*        ADD AVG-AVAIL-SUM TO AVG-AVAIL-TOT.
  4978. 117900*    IF (AVG-AVAIL-PCT > ZERO) AND
  4979. 118000*       (PLANT-TOT-HLD > ZERO)
  4980. 118100*        AND (AUDIT  = 1)
  4981. 118200*        MOVE 403 TO PAR-DR
  4982. 118300*        MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4983. 118400*        MOVE "AVG-AVAIL-PCT" TO FAN-DR
  4984. 118500*        MOVE AVG-AVAIL-PCT TO FA2-DR
  4985. 118600*        MOVE "X" TO SGN-DR
  4986. 118700*        MOVE PLANT-TOT-HLD TO FB-DR
  4987. 118800*        MOVE "PLANT-TOT-HLD" TO FBN-DR
  4988. 118900*        MOVE AVG-AVAIL-SUM TO FC-DR
  4989. 119000*        MOVE "AVG-AVAIL-SUM" TO FCN-DR
  4990. 119100*        DISPLAY P-SPACE
  4991. 119200*        DISPLAY DIS-REC
  4992. 119300*        MOVE 404 TO PAR-DR
  4993. 119400*        MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  4994. 119500*        MOVE "AVG-AVAIL-SUM" TO FAN-DR
  4995. 119600*        MOVE AVG-AVAIL-SUM TO FA-DR
  4996. 119700*        MOVE "+" TO SGN-DR
  4997. 119800*        MOVE " = " TO FILLER-DR
  4998. 119900*        MOVE SPACE TO FBS-DR
  4999. 120000*        MOVE SPACE TO FBN-DR
  5000. 120100*        MOVE AVG-AVAIL-TOT TO FC-DR
  5001. 120200*        MOVE "AVG-AVAIL-TOT" TO FCN-DR
  5002. 120300*        DISPLAY P-SPACE
  5003. 120400*        DISPLAY DIS-REC.
  5004. 120500     PERFORM 020-RD-IN.
  5005. 120600     GO TO 040-LOAD-REC.
  5006. 120700 410-CAL-7-PROC.
  5007. 120800     MOVE ZERO TO SUB4.
  5008. 120900 412-LP-TB.
  5009. 121000     ADD 1 TO SUB4.
  5010. 121100     IF SUB4 = 8
  5011. 121200         MOVE ZERO TO SUB4
  5012. 121300         GO TO 430-HGT-CROWN-CAL.
  5013. 121400     IF (PLANT-TOT-AC-TB (SUB4) = ZERO)
  5014. 121500         GO TO 412-LP-TB.
  5015. 121600     IF TYPE-SPEC-HLD = "T" OR "S"
  5016. 121700         MULTIPLY ACRE-FRAC-FAH BY PLANT-TOT-AC-TB (SUB4)
  5017. 121800         GIVING PLANTS-ACUM
  5018. 121900         DIVIDE PLOT-TOT-AC-TB (SUB4) INTO PLANTS-ACUM
  5019. 122000             GIVING PIA-AC (SUB4).
  5020. 122100     IF (TYPE-SPEC-HLD = "T" OR "S")
  5021. 122200         AND (AUDIT  = 1)
  5022. 122300         MOVE 412 TO PAR-DR
  5023. 122400         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5024. 122500         MOVE "ACRE-FRAC-FAH" TO FAN-DR
  5025. 122600         MOVE ACRE-FRAC-FAH TO FA-DR
  5026. 122700         MOVE "X" TO SGN-DR
  5027. 122800         MOVE PLANT-TOT-AC-TB (SUB4) TO FB-DR
  5028. 122900         MOVE "PLANT-TOT-AC-TB (SUB4)" TO FBN-DR
  5029. 123000         MOVE PLANTS-ACUM TO FC-DR
  5030. 123100         MOVE "PLANTS-ACUM" TO FCN-DR
  5031. 123200         MOVE "(  ) " TO PR2-DR
  5032. 123300         MOVE SUB4 TO SB2-DR
  5033. 123400         DISPLAY P-SPACE
  5034. 123500         DISPLAY DIS-REC
  5035. 123600         MOVE 413 TO PAR-DR
  5036. 123700         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5037. 123800         MOVE "PLOT-TOT-AC-TB (SUB4)" TO FAN-DR
  5038. 123900         MOVE PLOT-TOT-AC-TB (SUB4) TO FA-DR
  5039. 124000         MOVE "/" TO SGN-DR
  5040. 124100         MOVE PLANTS-ACUM TO FB-DR
  5041. 124200         MOVE "PLANTS-ACUM" TO FBN-DR
  5042. 124300         MOVE PIA-AC (SUB4) TO FC-DR
  5043. 124400         MOVE "PIA-AC (SUB4)" TO FCN-DR
  5044. 124500         MOVE "(  ) " TO PR1-DR
  5045. 124600         MOVE SUB4 TO SB1-DR
  5046. 124700         MOVE "(  ) " TO PR3-DR
  5047. 124800         MOVE SUB4 TO SB3-DR
  5048. 124900         DISPLAY P-SPACE
  5049. 125000         DISPLAY DIS-REC.
  5050. 125100     IF (TYPE-SPEC-HLD = "G" OR "F")
  5051. 125200         AND (PLOT-SAMP-SZ-FAH = ZERO)
  5052. 125300             IF PLOT-SIZE-0 = 1 MOVE 435.69 TO PLOT-SAMP-SZ-FAH
  5053. 125400                 ELSE
  5054. 125500             IF PLOT-SIZE-0 = 2 MOVE 217.80 TO PLOT-SAMP-SZ-FAH.
  5055. 125600     IF TYPE-SPEC-HLD = "G" OR "F"
  5056. 125700         MULTIPLY PLOT-TOT-AC-TB (SUB4) BY PLOT-SAMP-SZ-FAH
  5057. 125800             GIVING ACRE-SF-TOT
  5058. 125900         MULTIPLY 43560 BY PLANT-TOT-AC-TB (SUB4)
  5059. 126000             GIVING PLANTS-ACUM
  5060. 126100         DIVIDE ACRE-SF-TOT INTO PLANTS-ACUM
  5061. 126200             GIVING PIA-AC (SUB4) ROUNDED.
  5062. 126300     IF (TYPE-SPEC-HLD = "G" OR "F")
  5063. 126400         AND (AUDIT  = 1)
  5064. 126500         MOVE 413 TO PAR-DR
  5065. 126600         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5066. 126700         MOVE "PLOT-TOT-AC-TB (SUB4)" TO FAN-DR
  5067. 126800         MOVE  PLOT-TOT-AC-TB (SUB4)  TO FA-DR
  5068. 126900         MOVE "X" TO SGN-DR
  5069. 127000         MOVE PLOT-SAMP-SZ-FAH TO FB2-DR
  5070. 127100         MOVE "PLOT-SAMP-SZ-FAH" TO FBN-DR
  5071. 127200         MOVE ACRE-SF-TOT TO FC1-DR
  5072. 127300         MOVE "ACRE-SF-TOT" TO FCN-DR
  5073. 127400         MOVE "(  ) " TO PR1-DR
  5074. 127500         MOVE SUB4 TO SB1-DR
  5075. 127600         DISPLAY P-SPACE
  5076. 127700         DISPLAY DIS-REC
  5077. 127800         MOVE 414 TO PAR-DR
  5078. 127900         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5079. 128000         MOVE "CONSTANT" TO FAN-DR
  5080. 128100         MOVE 43560 TO FA-DR
  5081. 128200         MOVE "X" TO SGN-DR
  5082. 128300         MOVE PLANT-TOT-AC-TB (SUB4) TO FB-DR
  5083. 128400         MOVE "PLANT-TOT-AC-TB (SUB4)" TO FBN-DR
  5084. 128500         MOVE  PLANTS-ACUM  TO FC-DR
  5085. 128600         MOVE "PLANTS-ACUM" TO FCN-DR
  5086. 128700         MOVE "(  ) " TO PR2-DR
  5087. 128800         MOVE SUB4 TO SB2-DR
  5088. 128900         DISPLAY P-SPACE
  5089. 129000         DISPLAY DIS-REC
  5090. 129100         MOVE 415 TO PAR-DR
  5091. 129200         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5092. 129300         MOVE "ACRE-SF-TOT" TO FAN-DR
  5093. 129400         MOVE ACRE-SF-TOT TO FA1-DR
  5094. 129500         MOVE "/" TO SGN-DR
  5095. 129600         MOVE PLANTS-ACUM TO FB-DR
  5096. 129700         MOVE "PLANTS-ACUM" TO FBN-DR
  5097. 129800         MOVE PIA-AC (SUB4) TO FC-DR
  5098. 129900         MOVE "PIA-AC (SUB4)" TO FCN-DR
  5099. 130000         MOVE "(  ) " TO PR3-DR
  5100. 130100         MOVE SUB4 TO SB3-DR
  5101. 130200         DISPLAY P-SPACE
  5102. 130300         DISPLAY DIS-REC.
  5103. 130400     GO TO 412-LP-TB.
  5104. 130500 430-HGT-CROWN-CAL.
  5105. 130600     IF (PLANT-TOT-HGT > ZERO) AND (AVG-HGT-TOT > ZERO)
  5106. 130700         DIVIDE PLANT-TOT-HGT INTO AVG-HGT-TOT
  5107. 130800         GIVING AVG-HGT.
  5108. 130900     IF (PLANT-TOT-HGT > ZERO) AND (AVG-HGT-TOT > ZERO)
  5109. 131000         AND (AUDIT  = 1)
  5110. 131100         MOVE 430 TO PAR-DR
  5111. 131200         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5112. 131300         MOVE "PLANT-TOT-HGT" TO FAN-DR
  5113. 131400         MOVE PLANT-TOT-HGT TO FA-DR
  5114. 131500         MOVE "/" TO SGN-DR
  5115. 131600         MOVE AVG-HGT-TOT TO FB1-DR
  5116. 131700         MOVE "AVG-HGT-TOT" TO FBN-DR
  5117. 131800         MOVE AVG-HGT TO FC1-DR
  5118. 131900         MOVE "AVG-HGT" TO FCN-DR
  5119. 132000         DISPLAY P-SPACE
  5120. 132100         DISPLAY DIS-REC.
  5121. 132200     IF (PLANT-TOT-CROWN > ZERO) AND (AVG-CROWN-TOT > ZERO)
  5122. 132300         DIVIDE PLANT-TOT-CROWN INTO AVG-CROWN-TOT
  5123. 132400         GIVING AVG-CROWN.
  5124. 132500     IF (PLANT-TOT-CROWN > ZERO) AND (AVG-CROWN-TOT > ZERO)
  5125. 132600         AND (AUDIT  = 1)
  5126. 132700         MOVE 431 TO PAR-DR
  5127. 132800         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5128. 132900         MOVE "PLANT-TOT-CROWN" TO FAN-DR
  5129. 133000         MOVE  PLANT-TOT-CROWN  TO FA-DR
  5130. 133100         MOVE "/" TO SGN-DR
  5131. 133200         MOVE AVG-CROWN-TOT TO FB1-DR
  5132. 133300         MOVE "AVG-CROWN-TOT" TO FBN-DR
  5133. 133400         MOVE AVG-CROWN TO FC1-DR
  5134. 133500         MOVE "AVG-CROWN" TO FCN-DR
  5135. 133600         DISPLAY P-SPACE
  5136. 133700         DISPLAY DIS-REC.
  5137. 133800*    IF (PLANT-TOT-AVAIL > ZERO) AND (AVG-AVAIL-TOT > ZERO)
  5138. 133900*        DIVIDE PLANT-TOT-AVAIL INTO AVG-AVAIL-TOT
  5139. 134000*        GIVING AVG-AVAIL.
  5140. 134100*    IF (PLANT-TOT-AVAIL > ZERO) AND (AVG-AVAIL-TOT > ZERO)
  5141. 134200*        AND (AUDIT  = 1)
  5142. 134300*        MOVE 432 TO PAR-DR
  5143. 134400*        MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5144. 134500*        MOVE "PLANT-TOT-AVAIL" TO FAN-DR
  5145. 134600*        MOVE  PLANT-TOT-AVAIL  TO FA-DR
  5146. 134700*        MOVE "/" TO SGN-DR
  5147. 134800*        MOVE AVG-AVAIL-TOT TO FB-DR
  5148. 134900*        MOVE "AVG-AVAIL-TOT" TO FBN-DR
  5149. 135000*        MOVE AVG-AVAIL TO FC2-DR
  5150. 135100*        MOVE "AVG-AVAIL" TO FCN-DR
  5151. 135200*        DISPLAY P-SPACE
  5152. 135300*        DISPLAY DIS-REC.
  5153. 135400     MOVE ZERO TO SUB2.
  5154. 135500     SUBTRACT UTIL-AVG-2 FROM 100 GIVING PW-WUAF.
  5155. 135600     IF AUDIT  = 1
  5156. 135700         MOVE 433 TO PAR-DR
  5157. 135800         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5158. 135900         MOVE "CONSTANT" TO FAN-DR
  5159. 136000         MOVE 100 TO FA-DR
  5160. 136100         MOVE "-" TO SGN-DR
  5161. 136200         MOVE UTIL-AVG-2 TO FB-DR
  5162. 136300         MOVE "UTIL-AVG-2" TO FBN-DR
  5163. 136400         MOVE PW-WUAF TO FC-DR
  5164. 136500         MOVE "PW-WUAF" TO FCN-DR
  5165. 136600         DISPLAY P-SPACE
  5166. 136700         DISPLAY DIS-REC.
  5167. 136800     DIVIDE PW-WUAF INTO 100 GIVING
  5168. 136900         PW-WAUF.
  5169. 137000     IF AUDIT  = 1
  5170. 137100         MOVE 434 TO PAR-DR
  5171. 137200         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5172. 137300         MOVE "PW-WUAF" TO FAN-DR
  5173. 137400         MOVE  PW-WUAF  TO FA-DR
  5174. 137500         MOVE "/" TO SGN-DR
  5175. 137600         MOVE 100 TO FB-DR
  5176. 137700         MOVE "CONSTANT" TO FBN-DR
  5177. 137800         MOVE PW-WAUF TO FC2-DR
  5178. 137900         MOVE "PW-WAUF" TO FCN-DR
  5179. 138000         DISPLAY P-SPACE
  5180. 138100         DISPLAY DIS-REC.
  5181. 138200 450-LP.
  5182. 138300     IF SUB2 = 4
  5183. 138400         MOVE ZERO TO SUB2
  5184. 138500         GO TO 460-BUILD-SUMMARY.
  5185. 138600     ADD 1 TO SUB2.
  5186. 138700     IF GRAM-HC-TB (SUB2) = ZERO GO TO 450-LP.
  5187. 138800     MOVE GRAM-HC-TB (SUB2) TO PW-GRAMS-HLD.
  5188. 138900*    MOVE PLOT-TOT-HC-TB (SUB2) TO PW-PLOT-TOT.
  5189. 139000     MULTIPLY 100 BY PW-GRAMS-HLD GIVING PW-GRAMS.
  5190. 139100     IF AUDIT  = 1
  5191. 139200         MOVE 450 TO PAR-DR
  5192. 139300         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5193. 139400         MOVE "PW-GRAMS-HLD" TO FAN-DR
  5194. 139500         MOVE  PW-GRAMS-HLD  TO FA-DR
  5195. 139600         MOVE "X" TO SGN-DR
  5196. 139700         MOVE 100 TO FB-DR
  5197. 139800         MOVE "CONSTANT" TO FBN-DR
  5198. 139900         MOVE PW-GRAMS TO FC-DR
  5199. 140000         MOVE "PW-GRAMS" TO FCN-DR
  5200. 140100         MOVE "(  ) " TO PR1-DR
  5201. 140200         MOVE SUB2 TO SB1-DR
  5202. 140300         DISPLAY P-SPACE
  5203. 140400         DISPLAY DIS-REC.
  5204. 140500     DIVIDE PW-PLOT-TOT INTO PW-GRAMS GIVING PW-GRAMS-HLD.
  5205. 140600     IF AUDIT  = 1
  5206. 140700         MOVE 451 TO PAR-DR
  5207. 140800         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5208. 140900         MOVE "PW-PLOT-TOT" TO FAN-DR
  5209. 141000         MOVE  PW-PLOT-TOT  TO FA-DR
  5210. 141100         MOVE "/" TO SGN-DR
  5211. 141200         MOVE PW-GRAMS TO FB-DR
  5212. 141300         MOVE "PW-GRAMS" TO FBN-DR
  5213. 141400         MOVE PW-GRAMS-HLD TO FC-DR
  5214. 141500         MOVE "PW-GRAMS-HLD" TO FCN-DR
  5215. 141600         MOVE "(  ) " TO PR1-DR
  5216. 141700         MOVE SUB2 TO SB1-DR
  5217. 141800         DISPLAY P-SPACE
  5218. 141900         DISPLAY DIS-REC.
  5219. 142000     MULTIPLY .96 BY PW-GRAMS-HLD GIVING PW-GRAMS.
  5220. 142100     IF AUDIT  = 1
  5221. 142200         MOVE 452 TO PAR-DR
  5222. 142300         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5223. 142400         MOVE "PW-GRAMS-HLD" TO FAN-DR
  5224. 142500         MOVE  PW-GRAMS-HLD  TO FA-DR
  5225. 142600         MOVE "X" TO SGN-DR
  5226. 142700         MOVE CON96 TO FB2-DR
  5227. 142800         MOVE "CONSTANT" TO FBN-DR
  5228. 142900         MOVE PW-GRAMS TO FC-DR
  5229. 143000         MOVE "PW-GRAMS" TO FCN-DR
  5230. 143100         MOVE "(  ) " TO PR1-DR
  5231. 143200         MOVE SUB2 TO SB1-DR
  5232. 143300         DISPLAY P-SPACE
  5233. 143400         DISPLAY DIS-REC.
  5234. 143500     DIVIDE PW-SIZE INTO PW-GRAMS GIVING PW-LBS-ACRE ROUNDED.
  5235. 143600     IF AUDIT  = 1
  5236. 143700         MOVE 453 TO PAR-DR
  5237. 143800         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5238. 143900         MOVE "PW-SIZE" TO FAN-DR
  5239. 144000         MOVE  PW-SIZE  TO FA2-DR
  5240. 144100         MOVE "/" TO SGN-DR
  5241. 144200         MOVE PW-GRAMS TO FB-DR
  5242. 144300         MOVE "PW-GRAMS" TO FBN-DR
  5243. 144400         MOVE PW-LBS-ACRE TO FC-DR
  5244. 144500         MOVE "PW-LBS-ACRE" TO FCN-DR
  5245. 144600         DISPLAY P-SPACE
  5246. 144700         DISPLAY DIS-REC.
  5247. 144800     MULTIPLY PW-WAUF BY PW-LBS-ACRE
  5248. 144900         GIVING PW-PROD (SUB2) ROUNDED.
  5249. 145000     IF AUDIT  = 1
  5250. 145100         MOVE 454 TO PAR-DR
  5251. 145200         MOVE SPACE TO PR1-DR PR2-DR PR3-DR
  5252. 145300         MOVE "PW-WAUF" TO FAN-DR
  5253. 145400         MOVE  PW-WAUF  TO FA2-DR
  5254. 145500         MOVE "X" TO SGN-DR
  5255. 145600         MOVE PW-LBS-ACRE TO FB-DR
  5256. 145700         MOVE "PW-LBS-ACRE" TO FBN-DR
  5257. 145800         MOVE PW-PROD (SUB2) TO FC-DR
  5258. 145900         MOVE "PW-PROD (SUB2)" TO FCN-DR
  5259. 146000         MOVE "(  ) " TO PR3-DR
  5260. 146100         MOVE SUB2 TO SB3-DR
  5261. 146200         DISPLAY P-SPACE
  5262. 146300         DISPLAY DIS-REC.
  5263. 146400     GO TO 450-LP.
  5264. 146500 460-BUILD-SUMMARY.
  5265. 146600     MOVE SPACE TO DET-1 DET-2, REC-KEY8.
  5266. 146700     MOVE SWA-SCH TO SWA-P.
  5267. 146800     MOVE TRN-NUM-SCH TO TRN-P.
  5268. 146900     MOVE SPECIES-CD-SCH TO SPECIES-CD-P.
  5269. 147000     MOVE TYPE-SPEC-HLD TO SPECIES-TYPE-P.
  5270. 147100     MOVE PLANT-TOTAL    TO TOT-PLANTS-RK8 TOT-PLANTS-P.
  5271. 147200     MOVE SWAT-CNTL-HLD TO SWAT-RK8.
  5272. 147300     MOVE 8 TO REC-KEY-RK8.
  5273. 147400     MOVE SPEC-HLD TO SPECIES-KEY-RK8.
  5274. 147500     IF TYPE-SPEC-HLD = "T" OR "S"
  5275. 147600         MOVE "3" TO PLANT-TYP-RK8 ELSE
  5276. 147700         IF TYPE-SPEC-HLD = "G"
  5277. 147800             MOVE "1" TO PLANT-TYP-RK8 ELSE
  5278. 147900             IF TYPE-SPEC-HLD = "F"
  5279. 148000                 MOVE "2" TO PLANT-TYP-RK8.
  5280. 148100     MOVE AVG-HGT TO AVG-HT-RK8 AVG-HGT-P.
  5281. 148200     MOVE AVG-CROWN TO AVG-CROWN-RK8 AVG-CROWN-P.
  5282. 148300     IF (AVAIL-SW = ZERO) AND (AVG-AV-PCT = ZERO)
  5283. 148400         MOVE 100 TO AVG-AV-PCT.
  5284. 148500     MOVE ZERO TO AVAIL-SW.
  5285. 148600     MOVE AVG-AV-PCT TO WTD-AVG-AVAIL-RK8 WTD-AVG-AVAIL-P
  5286. 148700     IF UTIL-AVG-RD = 100 MOVE ZERO TO UTIL-AVG-RD.
  5287. 148800     MOVE UTIL-AVG-RD TO WTD-AVG-UTIL-RK8 WTD-AVG-UTIL-P.
  5288. 148900     IF PHNO-PLOT-AVG = ZERO
  5289. 149000         MOVE 6 TO PHNO-PLOT-AVG.
  5290. 149100     IF PHNO-AVG = ZERO
  5291. 149200         MOVE PHNO-PLOT-AVG TO PHNO-AVG.
  5292. 149300     MOVE PHNO-AVG TO WTD-AVG-PHNO-RK8 WTD-AVG-PHNO-P.
  5293. 149400     MOVE GRAM-HC-TB-RD TO GRP-3-RK8.
  5294. 149500     MOVE PW-GRP-PROD TO GRP-4-RK8.
  5295. 149600     MOVE PIA-FC-RD TO GRP-1-RK8.
  5296. 149700     MOVE PIA-AC2 TO GRP-2-RK8.
  5297. 149800     MOVE ZERO TO SUB3.
  5298. 149900 470-LP-TB.
  5299. 150000     ADD 1 TO SUB3.
  5300. 150100     IF SUB3 < 5
  5301. 150200         MOVE TOT-GRAMS-RK8 (SUB3) TO GRAMS-HGT-CLS-P (SUB3)
  5302. 150300       MOVE PW-PROD (SUB3) TO PROD-HGT-CLS-P (SUB3).
  5303. 150400     IF SUB3 < 7
  5304. 150500         MOVE FORM-CLS-RK8 (SUB3) TO PLANTS-FORM-CLS-P (SUB3)
  5305. 150600         MOVE AGE-CLS-RK8 (SUB3) TO PLANTS-AGE-CLS-P (SUB3)
  5306. 150700         GO TO 470-LP-TB.
  5307. 150800     MOVE AGE-CLS-RK8 (SUB3) TO PLANTS-AGE-CLS-P (SUB3).
  5308. 150900     MOVE REC-KEY8 TO FDR-D8.
  5309. 151000     MOVE PLOTS-CHRZ-HLD TO PLOTS-CHRZ-D8.
  5310. 151100     IF CHRZ-SW = 1
  5311. 151200         MOVE PLOTS-CHRZ-HLD-2 TO PLOTS-CHRZ-HLD
  5312. 151300         MOVE ZERO TO CHRZ-SW.
  5313. 151400     WRITE FDR-D8.
  5314. 151500     ADD 1 TO REC-CNT.
  5315. 151600     MOVE SPACE TO DIS-DT1 DIS-DT2.
  5316. 151700     INITIALIZE PLANT-TOT-TABLE, PLANT-CAL-TABLE,
  5317. 151800         PLANT-CAL-HLD, UTIL-PHENO-TABLE, PLANT-TOTAL,
  5318. 151900         UTIL-PHENO-HLD, HT-CLS-TABLE, FORM-CLS-TABLE,
  5319. 152000         AGE-CLS-TABLE, FORM-AGE-HOLD, AVG-HGT-CROWN-AVL
  5320. 152100         PROD-WGT-HLD DIS-DT1 DIS-DT2.
  5321. 152200     IF PRT-SW = 1 GO TO 475-PASS.
  5322. 152300     IF LINE-CNT > 50
  5323. 152400         PERFORM 500-OFLO THRU 500-EXIT.
  5324. 152500     WRITE FDR-P1 FROM DET-1 BEFORE 1.
  5325. 152600     WRITE FDR-P1 FROM DET-2 BEFORE 1.
  5326. 152700     WRITE FDR-P1 FROM P-SPACE BEFORE 1.
  5327. 152800     ADD 3 TO LINE-CNT.
  5328. 152900 475-PASS.
  5329. 153000     IF END-SW = 1
  5330. 153100         GO TO 700-END.
  5331. 153200     IF SDRP-SCH NOT = SDRP-D7
  5332. 153300         MOVE 99 TO LINE-CNT
  5333. 153400         MOVE 0 TO SWAT-SW SPEC-SW
  5334. 153500         GO TO 030-MV-IN.
  5335. 153600     IF SWAT-SW = 1
  5336. 153700         MOVE 0 TO SWAT-SW SPEC-SW
  5337. 153800         MOVE 55 TO LINE-CNT
  5338. 153900         GO TO 030-MV-IN.
  5339. 154000     IF SPEC-SW = 1
  5340. 154100         MOVE 0 TO SPEC-SW
  5341. 154200         GO TO 030-MV-IN.
  5342. 154300 500-OFLO.
  5343. 154400     IF SDRP-SCH NOT = SDRP-HLD
  5344. 154500         MOVE SDRP-SCH TO SDRP-HLD
  5345. 154600         ELSE GO TO 510-WRITE.
  5346. 154700     MOVE ADST-CD-SCH TO DE-CD-8822-DEC.
  5347. 154800     MOVE 0003 TO DE-NO-8801-DEC.
  5348. 154900     FIND ANY CODE-DEC.
  5349. 155000     MOVE DB-STATUS TO DATA-BASE-STATUS.
  5350. 155100     IF OK
  5351. 155200         GET CODE-DEC
  5352. 155300             MOVE DE-CD-NAM-8823-DEC  TO FUNC-HLD
  5353. 155400             MOVE ST-NM-HLD TO SN-HD-3
  5354. 155500         ELSE MOVE "UNKNOWN" TO SN-HD-3
  5355. 155600                  DN-HD-3 RAN-HD-3 PN-HD-3
  5356. 155700                 GO TO 510-WRITE.
  5357. 155800     MOVE SD-SCH TO DE-CD-8822-DEC.
  5358. 155900     MOVE 0003 TO DE-NO-8801-DEC.
  5359. 156000     FIND ANY CODE-DEC.
  5360. 156100     MOVE DB-STATUS TO DATA-BASE-STATUS.
  5361. 156200     IF OK
  5362. 156300         GET CODE-DEC
  5363. 156400         ELSE MOVE "UNKNOWN" TO
  5364. 156500                  DN-HD-3 RAN-HD-3 PN-HD-3
  5365. 156600                 GO TO 510-WRITE.
  5366. 156700     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  5367. 156800     MOVE DB-STATUS TO DATA-BASE-STATUS.
  5368. 156900     IF OK
  5369. 157000         GET CODE-EXPL-DECE
  5370. 157100         MOVE DE-CD-EXPLN-8827-DECE   TO EXPL-HLD
  5371. 157200         MOVE DIST-NM-HLD TO DN-HD-3
  5372. 157300       ELSE
  5373. 157400         MOVE "UNKNOWN" TO DN-HD-3 RAN-HD-3 PN-HD-3
  5374. 157500         GO TO 510-WRITE.
  5375. 157600     MOVE SDR-SCH TO DE-CD-8822-DEC.
  5376. 157700     MOVE 0003 TO DE-NO-8801-DEC.
  5377. 157800     FIND ANY CODE-DEC.
  5378. 157900     MOVE DB-STATUS TO DATA-BASE-STATUS.
  5379. 158000     IF OK
  5380. 158100         GET CODE-DEC
  5381. 158200         ELSE
  5382. 158300         MOVE "UNKNOWN" TO RAN-HD-3 PN-HD-3
  5383. 158400         GO TO 510-WRITE.
  5384. 158500     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  5385. 158600     MOVE DB-STATUS TO DATA-BASE-STATUS.
  5386. 158700     IF OK
  5387. 158800         GET CODE-EXPL-DECE
  5388. 158900         MOVE DE-CD-EXPLN-8827-DECE    TO EXPL-HLD
  5389. 159000         MOVE RA-NM-HLD TO RAN-HD-3
  5390. 159100       ELSE
  5391. 159200         MOVE "UNKNOWN" TO  RAN-HD-3 PN-HD-3
  5392. 159300         GO TO 510-WRITE.
  5393. 159400     MOVE SDRP-SCH TO DE-CD-8822-DEC.
  5394. 159500     MOVE 0003 TO DE-NO-8801-DEC.
  5395. 159600     FIND ANY CODE-DEC.
  5396. 159700     MOVE DB-STATUS TO DATA-BASE-STATUS.
  5397. 159800     IF OK
  5398. 159900         GET CODE-DEC
  5399. 160000         ELSE MOVE "UNKNOWN" TO  PN-HD-3
  5400. 160100             GO TO 510-WRITE.
  5401. 160200     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  5402. 160300     MOVE DB-STATUS TO DATA-BASE-STATUS.
  5403. 160400     IF OK
  5404. 160500         GET CODE-EXPL-DECE
  5405. 160600         MOVE DE-CD-EXPLN-8827-DECE   TO EXPL-HLD
  5406. 160700         MOVE PU-NM-HLD TO PN-HD-3
  5407. 160800       ELSE
  5408. 160900         MOVE "UNKNOWN" TO PN-HD-3.
  5409. 161000 510-WRITE.
  5410. 161100     IF PRT-SW = 1 GO TO 500-EXIT.
  5411. 161200     IF LINE-CNT = 99
  5412. 161300         MOVE ZERO TO PG-CNT.
  5413. 161400     ADD 1 TO PG-CNT.
  5414. 161500*    IF PG-CNT > 100
  5415. 161600*        MOVE ZERO TO LINE-CNT
  5416. 161700*        GO TO 500-EXIT.
  5417. 161800     MOVE ZERO TO LINE-CNT.
  5418. 161900     MOVE PG-CNT TO PG-HD-1.
  5419. 162000     MOVE ADST-CD-SCH TO ST-HD-3.
  5420. 162100     MOVE DIST-CD-SCH TO DS-HD-3.
  5421. 162200     MOVE PLU-CD-SCH TO PS-HD-3.
  5422. 162300     MOVE RA-CD-SCH TO RA-HD-3.
  5423. 162400     WRITE FDR-P1 FROM P-SPACE BEFORE ADVANCING PAGE.
  5424. 162500     WRITE FDR-P1 FROM HEAD-1 BEFORE 1.
  5425. 162600     WRITE FDR-P1 FROM HEAD-2 BEFORE 1.
  5426. 162700     WRITE FDR-P1 FROM HEAD-3 BEFORE 1.
  5427. 162800     WRITE FDR-P1 FROM HEAD-4 BEFORE 2.
  5428. 162900     WRITE FDR-P1 FROM HEAD-5 BEFORE 1.
  5429. 163000     WRITE FDR-P1 FROM HEAD-6 BEFORE 1.
  5430. 163100     WRITE FDR-P1 FROM HEAD-7 BEFORE 2.
  5431. 163200     MOVE 10 TO LINE-CNT.
  5432. 163300 500-EXIT.
  5433. 163400     EXIT.
  5434. 163500 700-END.
  5435. 163600     DISPLAY REC-CNT "REC-CNT".
  5436. 163700     CLOSE FILE-D7, FILE-D8, FILE-P1.  FINISH DIC-DE.
  5437. 163800     STOP RUN.
  5438. 000000*-----------------------------------------------------------------
  5439. 000100 IDENTIFICATION DIVISION.
  5440. 000200 PROGRAM-ID. ES110U.
  5441. 000300*        INITIAL EDIT/UPDATE OF PLANTS (PHENO/WEIGHTS),
  5442. 000400*            ANIMALS (FORAGE/USE) FACTORS - V6, VF, VU, VP FORMATS
  5443. 000500*
  5444. 000600 AUTHOR. CARLANDER, RON BAKER.
  5445. 000700 INSTALLATION.         BLM.
  5446. 000800 DATE-WRITTEN.         AUGUST 1979.
  5447. 000900 ENVIRONMENT DIVISION.
  5448. 001000 CONFIGURATION SECTION.
  5449. 001100 SOURCE-COMPUTER.      LEVEL-66-ASCII.
  5450. 001200 OBJECT-COMPUTER.      LEVEL-66-ASCII SEQUENCE IS EBCDIC.
  5451. 001300 INPUT-OUTPUT SECTION.
  5452. 001400 FILE-CONTROL.
  5453. 001500     SELECT  NEW-FILE  ASSIGN D1
  5454. 001600             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  5455. 001700     SELECT  TRAN-FILE ASSIGN I1
  5456. 001800             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  5457. 001900     SELECT  OPTIONAL PREV-FILE ASSIGN I2
  5458. 002000             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  5459. 002100     SELECT  SORT-WORK ASSIGN I1 I2 I3.
  5460. 002200 DATA DIVISION.
  5461. 002300 FILE SECTION.
  5462. 002400 FD  PREV-FILE
  5463. 002500     CODE-SET IS GBCD
  5464. 002600     LABEL RECORDS ARE STANDARD
  5465. 002700     DATA RECORDS ARE VF1X-RCD VP1X-RCD VU1X-RCD V61X-RCD.
  5466. 002800 01  VF1X-RCD.
  5467. 002900     05  KEY-VF1X.
  5468. 003000         10  DIC-VF1X.
  5469. 003100             15  REC-TYP-3529-VF1X                PIC X(2).
  5470. 003200             15  FMT-NUM-3576-VF1X                PIC X(1).
  5471. 003300             15  FMT-CD-3579-VF1X                 PIC X(1).
  5472. 003400         10  BLM-ADM-U-0003-VF1X.
  5473. 003500             15  BLM-ADM-U-0003-ST-VF1X           PIC X(2).
  5474. 003600             15  BLM-ADM-U-0003-DIST-VF1X         PIC X(2).
  5475. 003700             15  FILLER                           PIC XXXX.
  5476. 003800         10  DATA-DATE-6618-VF1X.
  5477. 003900             15  DATA-DATE-6618-YY-VF1X           PIC X(2).
  5478. 004000             15  DATA-DATE-6618-MM-VF1X           PIC X(2).
  5479. 004100             15  DATA-DATE-6618-DD-VF1X           PIC X(2).
  5480. 004200         10  ACTN-CD-7350-VF1X                    PIC X(1).
  5481. 004300         10  LIN-NUM-3578-VF1X                    PIC X(4).
  5482. 004400     05  ANML-GRZG-CD-3929-VF1X               PIC X(2).
  5483. 004500     05  MON-FORG-RQMT-LBS-3551-VF1X          PIC X(4).
  5484. 004600     05  ANML-HGT-CLS-CD-3548-VF1X            PIC X(1).
  5485. 004700     05  FILLER         PIC X(36).
  5486. 004800 01  VP1X-RCD.
  5487. 004900     05  KEY-VP1X.
  5488. 005000         10  DIC-VP1X.
  5489. 005100             15  REC-TYP-3529-VP1X                PIC X(2).
  5490. 005200             15  FMT-NUM-3576-VP1X                PIC X(1).
  5491. 005300             15  FMT-CD-3579-VP1X                 PIC X(1).
  5492. 005400         10  BLM-ADM-U-0003-VP1X.
  5493. 005500             15  BLM-ADM-U-0003-ST-VP1X           PIC X(2).
  5494. 005600             15  BLM-ADM-U-0003-DIST-VP1X         PIC X(2).
  5495. 005700             15  BLM-ADM-U-0003-RA-VP1X           PIC X(2).
  5496. 005800             15  BLM-ADM-U-0003-PLU-VP1X          PIC X(2).
  5497. 005900         10  DATA-DATE-6618-VP1X.
  5498. 006000             15  DATA-DATE-6618-YY-VP1X           PIC X(2).
  5499. 006100             15  DATA-DATE-6618-MM-VP1X           PIC X(2).
  5500. 006200             15  DATA-DATE-6618-DD-VP1X           PIC X(2).
  5501. 006300         10  ACTN-CD-7350-VP1X                    PIC X(1).
  5502. 006400         10  LIN-NUM-3578-VP1X                    PIC X(4).
  5503. 006500     05  PLANT-CD-2646-VP1X                       PIC X(7).
  5504. 006600     05  PHNO-GP-VP1X     PIC X(32).
  5505. 006700     05  PHNO-ADJ-GP-VP1X REDEFINES PHNO-GP-VP1X.
  5506. 006800         07  PHNO-ADJ-VP1X  OCCURS 8 TIMES.
  5507. 006900             09  PHNO-ADJ-1-VP1X   PIC XX.
  5508. 007000             09  PHNO-ADJ-2-VP1X  PIC XX.
  5509. 007100     05  PHNO-ADJ-FCTR-3545-VP1X REDEFINES PHNO-GP-VP1X
  5510. 007200             OCCURS 8 TIMES     PIC 99V99.
  5511. 007300     05  PLANT-TYP-3590-VP1X    PIC X.
  5512. 007400     05  FILLER                   PIC XXXX.
  5513. 007500 01  VU1X-RCD.
  5514. 007600     05  KEY-VU1X.
  5515. 007700         10  DIC-VU1X.
  5516. 007800             15  REC-TYP-3529-VU1X                PIC X(2).
  5517. 007900             15  FMT-NUM-3576-VU1X                PIC X(1).
  5518. 008000             15  FMT-CD-3579-VU1X                 PIC X(1).
  5519. 008100         10  BLM-ADM-U-0003-VU1X.
  5520. 008200             15  BLM-ADM-U-0003-ST-VU1X           PIC X(2).
  5521. 008300             15  BLM-ADM-U-0003-DIST-VU1X         PIC X(2).
  5522. 008400             15  BLM-ADM-U-0003-RA-VU1X           PIC X(2).
  5523. 008500             15  BLM-ADM-U-0003-PLU-VU1X          PIC X(2).
  5524. 008600         10  DATA-DATE-6618-VU1X.
  5525. 008700             15  DATA-DATE-6618-YY-VU1X           PIC X(2).
  5526. 008800             15  DATA-DATE-6618-MM-VU1X           PIC X(2).
  5527. 008900             15  DATA-DATE-6618-DD-VU1X           PIC X(2).
  5528. 009000         10  ACTN-CD-7350-VU1X                    PIC X(1).
  5529. 009100         10  DIET-USE-TYP-3917-VU1X               PIC X(1).
  5530. 009200         10  LIN-NUM-3578-VU1X                    PIC X(4).
  5531. 009300     05  PLANT-CD-2646-VU1X                       PIC X(7).
  5532. 009400     05  AUF-3928-VU1X-RD    PIC X(15).
  5533. 009500     05  AUF-3928-VU1X REDEFINES AUF-3928-VU1X-RD
  5534. 009600                        OCCURS 5 TIMES   PIC XXX.
  5535. 009700     05  ANML-GRZG-CD-3929-VU1X                   PIC X(2).
  5536. 009800     05  PUF-3511-VU1X     PIC X(02) OCCURS 5 TIMES.
  5537. 009900     05  PLANT-TYP-3590-VU1X   PIC X.
  5538. 010000     05  FILLER                    PIC X(7).
  5539. 010100 01  REC-V61X.
  5540. 010200     05  KEY-V61X.
  5541. 010300         10  DIC-V61X.
  5542. 010400             15  REC-TYP-3529-V61X                PIC X(2).
  5543. 010500             15  FMT-NUM-3576-V61X                PIC X(1).
  5544. 010600             15  FMT-CD-3579-V61X                 PIC X(1).
  5545. 010700         10  BLM-ADM-U-0003-V61X.
  5546. 010800             15  BLM-ADM-U-0003-ST-V61X           PIC X(2).
  5547. 010900             15  BLM-ADM-U-0003-DIST-V61X         PIC X(2).
  5548. 011000             15  BLM-ADM-U-0003-RA-V61X           PIC X(2).
  5549. 011100             15  BLM-ADM-U-0003-PLU-V61X          PIC X(2).
  5550. 011200         10  DATA-DATE-6618-V61X.
  5551. 011300             15  DATA-DATE-6618-YY-V61X           PIC X(2).
  5552. 011400         15  DATA-DATE-6618-MM-V61X          PIC X(2).
  5553. 011500             15  DATA-DATE-6618-DD-V61X           PIC X(2).
  5554. 011600         10  ACTN-CD-7350-V61X                    PIC X(1).
  5555. 011700         10  LIN-NUM-3578-V61X                    PIC X(4).
  5556. 011800     05  PLANT-CD-2646-V61X                       PIC X(7).
  5557. 011900     05  PHNO-STG-CD-3712-V61X                    PIC X(1).
  5558. 012000     05  GRAMS-GRN-WGT-3941-V61X                  PIC X(4).
  5559. 012100     05  ADW-PCT-3546-V61X                        PIC X(3).
  5560. 012200     05  GRAMS-DRY-WGT-3942-V61X                  PIC X(4).
  5561. 012300     05  GRP-1-V61X.
  5562. 012400         07  BASAL-DIMS-3533-MIN-V61X                 PIC XXXX.
  5563. 012500         07  BASAL-DIMS-3533-MAX-V61X                 PIC XXXX.
  5564. 012600         07  CROWN-DIMS-3534-MIN-V61X                 PIC X(03).
  5565. 012700         07  CROWN-DIMS-3534-MAX-V61X                 PIC X(03).
  5566. 012800         07  HGT-AVG-3504-V61X                        PIC X(04).
  5567. 012900         07  AVG-LDR-LGT-7313-V61X                    PIC X(03).
  5568. 013000     05  PLANT-TYP-3590-V61X   PIC X.
  5569. 013100     05  FILLER               PIC X(02).
  5570. 013200 FD  TRAN-FILE
  5571. 013300     CODE-SET IS GBCD
  5572. 013400     LABEL RECORDS ARE STANDARD
  5573. 013500     DATA RECORD IS TF-RCD.
  5574. 013600 01  TF-RCD.
  5575. 013700     03  REC-TYP-TF    PIC XX.
  5576. 013800     03  REC-NUM-CD-TF PIC XX.
  5577. 013900     03  SDRP-TF.
  5578. 014000         05  ST-TF     PIC XX.
  5579. 014100         05  DS-TF     PIC XX.
  5580. 014200         05  RA-TF     PIC XX.
  5581. 014300         05  PU-TF     PIC XX.
  5582. 014400     03  DATE-TF       PIC X(6).
  5583. 014500     03  ACTN-TF       PIC X.
  5584. 014600     03  GRP-1-TF.
  5585. 014700         05  DIET-TYP-VU-TF   PIC X.
  5586. 014800         05  LINE-VU-TF       PIC XXXX.
  5587. 014900         05  PLANT-CD-VU-TF   PIC X(7).
  5588. 015000         05  DATA-VU-TF.
  5589. 015100             07  AUF-GRP-VU-TF    PIC X(15).
  5590. 015200             07  ANML-GZ-CD-VU-TF PIC XX.
  5591. 015300             07  PUF-GRP-VU-TF    PIC X(10).
  5592. 015400             07  FILLER           PIC X(8).
  5593. 015500     03  GRP-2-TF REDEFINES GRP-1-TF.
  5594. 015600         05  LINE-TF    PIC XXXX.
  5595. 015700         05  DATA-V6FP-TF.
  5596. 015800             07  PLANT-CD-TF.
  5597. 015900                 09  ANML-GZ-CD-VF-TF  PIC XX.
  5598. 016000                 09  FILLER            PIC X(5).
  5599. 016100             07  PHNO-STG-TF  PIC X.
  5600. 016200             07  FILLER      PIC X(35).
  5601. 016300 FD  NEW-FILE
  5602. 016400     CODE-SET IS GBCD
  5603. 016500     LABEL RECORDS ARE STANDARD
  5604. 016600     DATA RECORDS ARE VF1Z-RCD VP1Z-RCD VU1Z-RCD V61Z-RCD.
  5605. 016700 01  VF1Z-RCD.
  5606. 016800     05  KEY-VF1Z.
  5607. 016900         10  DIC-VF1Z.
  5608. 017000             15  REC-TYP-3529-VF1Z                PIC X(2).
  5609. 017100             15  FMT-NUM-3576-VF1Z                PIC X(1).
  5610. 017200             15  FMT-CD-3579-VF1Z                 PIC X(1).
  5611. 017300         10  BLM-ADM-U-0003-VF1Z.
  5612. 017400             15  BLM-ADM-U-0003-ST-VF1Z           PIC X(2).
  5613. 017500             15  BLM-ADM-U-0003-DIST-VF1Z         PIC X(2).
  5614. 017600             15  FILLER                           PIC XXXX.
  5615. 017700         10  DATA-DATE-6618-VF1Z.
  5616. 017800             15  DATA-DATE-6618-YY-VF1Z           PIC X(2).
  5617. 017900             15  DATA-DATE-6618-MM-VF1Z           PIC X(2).
  5618. 018000             15  DATA-DATE-6618-DD-VF1Z           PIC X(2).
  5619. 018100         10  ACTN-CD-7350-VF1Z                    PIC X(1).
  5620. 018200         10  LIN-NUM-3578-VF1Z                    PIC X(4).
  5621. 018300     05  ANML-GRZG-CD-3929-VF1Z               PIC X(2).
  5622. 018400     05  MON-FORG-RQMT-LBS-3551-VF1Z          PIC X(4).
  5623. 018500     05  ANML-HGT-CLS-CD-3548-VF1Z            PIC X(1).
  5624. 018600     05  OPEN-VF1Z         PIC X(36).
  5625. 018700 01  VP1Z-RCD.
  5626. 018800     05  KEY-VP1Z.
  5627. 018900         10  DIC-VP1Z.
  5628. 019000             15  REC-TYP-3529-VP1Z                PIC X(2).
  5629. 019100             15  FMT-NUM-3576-VP1Z                PIC X(1).
  5630. 019200             15  FMT-CD-3579-VP1Z                 PIC X(1).
  5631. 019300         10  BLM-ADM-U-0003-VP1Z.
  5632. 019400             15  BLM-ADM-U-0003-ST-VP1Z           PIC X(2).
  5633. 019500             15  BLM-ADM-U-0003-DIST-VP1Z         PIC X(2).
  5634. 019600             15  BLM-ADM-U-0003-RA-VP1Z           PIC X(2).
  5635. 019700             15  BLM-ADM-U-0003-PLU-VP1Z          PIC X(2).
  5636. 019800         10  DATA-DATE-6618-VP1Z.
  5637. 019900             15  DATA-DATE-6618-YY-VP1Z           PIC X(2).
  5638. 020000             15  DATA-DATE-6618-MM-VP1Z           PIC X(2).
  5639. 020100             15  DATA-DATE-6618-DD-VP1Z           PIC X(2).
  5640. 020200         10  ACTN-CD-7350-VP1Z                    PIC X(1).
  5641. 020300         10  LIN-NUM-3578-VP1Z                    PIC X(4).
  5642. 020400     05  PLANT-CD-2646-VP1Z                       PIC X(7).
  5643. 020500     05  PHNO-GP-VP1Z     PIC X(32).
  5644. 020600     05  PHNO-ADJ-GP-VP1Z REDEFINES PHNO-GP-VP1Z.
  5645. 020700         07  PHNO-ADJ-VP1Z  OCCURS 8 TIMES.
  5646. 020800             09  PHNO-ADJ-1-VP1Z   PIC XX.
  5647. 020900             09  PHNO-ADJ-2-VP1Z  PIC XX.
  5648. 021000     05  PHNO-ADJ-FCTR-3545-VP1Z REDEFINES PHNO-GP-VP1Z
  5649. 021100             OCCURS 8 TIMES     PIC 99V99.
  5650. 021200     05  PLANT-TYP-3590-VP1Z    PIC X.
  5651. 021300     05  OPEN-VP1Z                   PIC XXXX.
  5652. 021400 01  VU1Z-RCD.
  5653. 021500     05  KEY-VU1Z.
  5654. 021600         10  DIC-VU1Z.
  5655. 021700             15  REC-TYP-3529-VU1Z                PIC X(2).
  5656. 021800             15  FMT-NUM-3576-VU1Z                PIC X(1).
  5657. 021900             15  FMT-CD-3579-VU1Z                 PIC X(1).
  5658. 022000         10  BLM-ADM-U-0003-VU1Z.
  5659. 022100             15  BLM-ADM-U-0003-ST-VU1Z           PIC X(2).
  5660. 022200             15  BLM-ADM-U-0003-DIST-VU1Z         PIC X(2).
  5661. 022300             15  BLM-ADM-U-0003-RA-VU1Z           PIC X(2).
  5662. 022400             15  BLM-ADM-U-0003-PLU-VU1Z          PIC X(2).
  5663. 022500         10  DATA-DATE-6618-VU1Z.
  5664. 022600             15  DATA-DATE-6618-YY-VU1Z           PIC X(2).
  5665. 022700             15  DATA-DATE-6618-MM-VU1Z           PIC X(2).
  5666. 022800             15  DATA-DATE-6618-DD-VU1Z           PIC X(2).
  5667. 022900         10  ACTN-CD-7350-VU1Z                    PIC X(1).
  5668. 023000         10  DIET-USE-TYP-3917-VU1Z               PIC X(1).
  5669. 023100         10  LIN-NUM-3578-VU1Z                    PIC X(4).
  5670. 023200     05  PLANT-CD-2646-VU1Z                       PIC X(7).
  5671. 023300     05  AUF-3928-VU1Z-RD    PIC X(15).
  5672. 023400     05  AUF-3928-VU1Z REDEFINES AUF-3928-VU1Z-RD
  5673. 023500                        OCCURS 5 TIMES   PIC XXX.
  5674. 023600     05  ANML-GRZG-CD-3929-VU1Z                   PIC X(2).
  5675. 023700     05  PUF-3511-VU1Z     PIC X(02) OCCURS 5 TIMES.
  5676. 023800     05  PLANT-TYP-3590-VU1Z   PIC X.
  5677. 023900     05  OPEN-VU1Z                    PIC X(7).
  5678. 024000 01  REC-V61Z.
  5679. 024100     05  KEY-V61Z.
  5680. 024200         10  DIC-V61Z.
  5681. 024300             15  REC-TYP-3529-V61Z                PIC X(2).
  5682. 024400             15  FMT-NUM-3576-V61Z                PIC X(1).
  5683. 024500             15  FMT-CD-3579-V61Z                 PIC X(1).
  5684. 024600         10  BLM-ADM-U-0003-V61Z.
  5685. 024700             15  BLM-ADM-U-0003-ST-V61Z           PIC X(2).
  5686. 024800             15  BLM-ADM-U-0003-DIST-V61Z         PIC X(2).
  5687. 024900             15  BLM-ADM-U-0003-RA-V61Z           PIC X(2).
  5688. 025000             15  BLM-ADM-U-0003-PLU-V61Z          PIC X(2).
  5689. 025100         10  DATA-DATE-6618-V61Z.
  5690. 025200             15  DATA-DATE-6618-YY-V61Z           PIC X(2).
  5691. 025300             15  DATA-DATE-6618-MM-V61Z           PIC X(2).
  5692. 025400             15  DATA-DATE-6618-DD-V61Z           PIC X(2).
  5693. 025500         10  ACTN-CD-7350-V61Z                    PIC X(1).
  5694. 025600         10  LIN-NUM-3578-V61Z                    PIC X(4).
  5695. 025700     05  PLANT-CD-2646-V61Z                       PIC X(7).
  5696. 025800     05  PHNO-STG-CD-3712-V61Z                    PIC X(1).
  5697. 025900     05  GRAMS-GRN-WGT-3941-V61Z                  PIC X(4).
  5698. 026000     05  ADW-PCT-3546-V61Z                        PIC X(3).
  5699. 026100     05  GRAMS-DRY-WGT-3942-V61Z                  PIC X(4).
  5700. 026200     05  GRP-1-V61Z.
  5701. 026300         07  BASAL-DIMS-3533-MIN-V61Z                 PIC X(04).
  5702. 026400         07  BASAL-DIMS-3533-MAX-V61Z                 PIC X(04).
  5703. 026500         07  CROWN-DIMS-3534-MIN-V61Z                 PIC X(03).
  5704. 026600         07  CROWN-DIMS-3534-MAX-V61Z                 PIC X(03).
  5705. 026700         07  HGT-AVG-3504-V61Z                        PIC X(04).
  5706. 026800         07  AVG-LDR-LGT-7313-V61Z                    PIC X(03).
  5707. 026900     05  PLANT-TYP-3590-V61Z   PIC X.
  5708. 027000     05  REC-CNT-V61Z    PIC 99.
  5709. 027100*
  5710. 027200 SD  SORT-WORK
  5711. 027300     DATA RECORD IS SORT-RCD.
  5712. 027400 01  SORT-RCD.
  5713. 027500     03  SR-KEY.
  5714. 027600         05  REC-TYP-SR    PIC XX.
  5715. 027700         05  REC-NUM-CD-SR PIC XX.
  5716. 027800         05  SDRP-SR.
  5717. 027900             07  ST-SR     PIC XX.
  5718. 028000             07  DS-SR     PIC XX.
  5719. 028100             07  RA-SR     PIC XX.
  5720. 028200             07  PU-SR     PIC XX.
  5721. 028300         05  LINE-SR       PIC XXXX.
  5722. 028400         05  PLANT-CD-SR   PIC X(7).
  5723. 028500         05  PHNO-STG-SR  PIC X.
  5724. 028600         05  ANML-GZ-CD-SR   PIC XX.
  5725. 028700     03  REC-HLD-SR.
  5726. 028800         05  FILLER                  PIC X(23).
  5727. 028900         05  DATA-V6FP-SR.
  5728. 029000             07  FILLER      PIC X.
  5729. 029100             07  DATA-VU-SR  PIC X(42).
  5730. 029200 WORKING-STORAGE SECTION.
  5731. 029300 77 END-OF-TRAN        PIC X(01) VALUE " ".
  5732. 029400 77  CTL-SAVE        PIC X(12) VALUE SPACES.
  5733. 029500 77 END-OF-PREV        PIC X(01) VALUE " ".
  5734. 029600 77 LAST-LIN-NUM      PIC 9(04) VALUE 0000.
  5735. 029700 77 DATE-SW            PIC X(01).
  5736. 029800 77 DATE-MV-SW         PIC X(01).
  5737. 029900 77 TODAYS-DATE        PIC X(06).
  5738. 030000 01  PARAMETER.
  5739. 030100     03  RELINE-CHK    PIC XXX.
  5740. 030200     03  FILLER        PIC X(77).
  5741. 030300 01  CTL.
  5742. 030400     03  RECD-ID-C    PIC XXXX.
  5743. 030500     03  SDRP-C      PIC X(8).
  5744. 030600 01  CTRS.
  5745. 030700     02  VF1-CTR     PIC 99999 VALUE 0.
  5746. 030800     02  VP1-CTR     PIC 99999 VALUE 0.
  5747. 030900     02  VU1-CTR     PIC 99999 VALUE 0.
  5748. 031000     02  V61-CTR     PIC 99999 VALUE 0.
  5749. 031100 01 DATE-WORK.
  5750. 031200     02  DW-YY         PIC X(02).
  5751. 031300     02  DW-MM         PIC X(02).
  5752. 031400     02  DW-DD         PIC X(02).
  5753. 031500 01  MOVED-DATE.
  5754. 031600     02  MD-DD         PIC XX.
  5755. 031700     02  MD-YY         PIC XX.
  5756. 031800     02  MD-MM         PIC XX.
  5757. 031900 01  PREV-CTL.
  5758. 032000     03  RECD-ID-PC   PIC XXXX.
  5759. 032100     03  SDRP-PC  PIC X(8).
  5760. 032200     03  LINE-PC PIC XXXX.
  5761. 032300 01  TRAN-CTL    PIC X(16)   VALUE SPACE.
  5762. 032400 01  VF1K-RCD.
  5763. 032500     05  KEY-VF1K.
  5764. 032600         10  DIC-VF1K.
  5765. 032700             15  REC-TYP-3529-VF1K                PIC X(2).
  5766. 032800             15  FMT-NUM-3576-VF1K                PIC X(1).
  5767. 032900             15  FMT-CD-3579-VF1K                 PIC X(1).
  5768. 033000         10  BLM-ADM-U-0003-VF1K.
  5769. 033100             15  BLM-ADM-U-0003-ST-VF1K           PIC X(2).
  5770. 033200             15  BLM-ADM-U-0003-DIST-VF1K         PIC X(2).
  5771. 033300             15  FILLER                           PIC XXXX.
  5772. 033400         10  DATA-DATE-6618-VF1K.
  5773. 033500             15  DATA-DATE-6618-YY-VF1K           PIC X(2).
  5774. 033600             15  DATA-DATE-6618-MM-VF1K           PIC X(2).
  5775. 033700             15  DATA-DATE-6618-DD-VF1K           PIC X(2).
  5776. 033800         10  ACTN-CD-7350-VF1K                    PIC X(1).
  5777. 033900         10  LIN-NUM-3578-VF1K                    PIC X(4).
  5778. 034000     05  ANML-GRZG-CD-3929-VF1K               PIC X(2).
  5779. 034100     05  MON-FORG-RQMT-LBS-3551-VF1K          PIC X(4).
  5780. 034200     05  ANML-HGT-CLS-CD-3548-VF1K            PIC X(1).
  5781. 034300     05  FILLER         PIC X(36).
  5782. 034400 01  VP1K-RCD.
  5783. 034500     05  KEY-VP1K.
  5784. 034600         10  DIC-VP1K.
  5785. 034700             15  REC-TYP-3529-VP1K                PIC X(2).
  5786. 034800             15  FMT-NUM-3576-VP1K                PIC X(1).
  5787. 034900             15  FMT-CD-3579-VP1K                 PIC X(1).
  5788. 035000         10  BLM-ADM-U-0003-VP1K.
  5789. 035100             15  BLM-ADM-U-0003-ST-VP1K           PIC X(2).
  5790. 035200             15  BLM-ADM-U-0003-DIST-VP1K         PIC X(2).
  5791. 035300             15  BLM-ADM-U-0003-RA-VP1K           PIC X(2).
  5792. 035400             15  BLM-ADM-U-0003-PLU-VP1K          PIC X(2).
  5793. 035500         10  DATA-DATE-6618-VP1K.
  5794. 035600             15  DATA-DATE-6618-YY-VP1K           PIC X(2).
  5795. 035700             15  DATA-DATE-6618-MM-VP1K           PIC X(2).
  5796. 035800             15  DATA-DATE-6618-DD-VP1K           PIC X(2).
  5797. 035900         10  ACTN-CD-7350-VP1K                    PIC X(1).
  5798. 036000         10  LIN-NUM-3578-VP1K                    PIC X(4).
  5799. 036100     05  PLANT-CD-2646-VP1K                       PIC X(7).
  5800. 036200     05  PHNO-GP-VP1K     PIC X(32).
  5801. 036300     05  PHNO-ADJ-GP-VP1K REDEFINES PHNO-GP-VP1K.
  5802. 036400         07  PHNO-ADJ-VP1K  OCCURS 8 TIMES.
  5803. 036500             09  PHNO-ADJ-1-VP1K   PIC XX.
  5804. 036600             09  PHNO-ADJ-2-VP1K  PIC XX.
  5805. 036700     05  PHNO-ADJ-FCTR-3545-VP1K REDEFINES PHNO-GP-VP1K
  5806. 036800             OCCURS 8 TIMES     PIC 99V99.
  5807. 036900     05  PLANT-TYP-3590-VP1K    PIC X.
  5808. 037000     05  FILLER                   PIC XXXX.
  5809. 037100 01  VU1K-RCD.
  5810. 037200     05  KEY-VU1K.
  5811. 037300         10  DIC-VU1K.
  5812. 037400             15  REC-TYP-3529-VU1K                PIC X(2).
  5813. 037500             15  FMT-NUM-3576-VU1K                PIC X(1).
  5814. 037600             15  FMT-CD-3579-VU1K                 PIC X(1).
  5815. 037700         10  BLM-ADM-U-0003-VU1K.
  5816. 037800             15  BLM-ADM-U-0003-ST-VU1K           PIC X(2).
  5817. 037900             15  BLM-ADM-U-0003-DIST-VU1K         PIC X(2).
  5818. 038000             15  BLM-ADM-U-0003-RA-VU1K           PIC X(2).
  5819. 038100             15  BLM-ADM-U-0003-PLU-VU1K          PIC X(2).
  5820. 038200         10  DATA-DATE-6618-VU1K.
  5821. 038300             15  DATA-DATE-6618-YY-VU1K           PIC X(2).
  5822. 038400             15  DATA-DATE-6618-MM-VU1K           PIC X(2).
  5823. 038500             15  DATA-DATE-6618-DD-VU1K           PIC X(2).
  5824. 038600         10  ACTN-CD-7350-VU1K                    PIC X(1).
  5825. 038700         10  DIET-USE-TYP-3917-VU1K               PIC X(1).
  5826. 038800         10  LIN-NUM-3578-VU1K                    PIC X(4).
  5827. 038900     05  PLANT-CD-2646-VU1K                       PIC X(7).
  5828. 039000     05  AUF-3928-VU1K-RD    PIC X(15).
  5829. 039100     05  AUF-3928-VU1K REDEFINES AUF-3928-VU1K-RD
  5830. 039200                        OCCURS 5 TIMES   PIC XXX.
  5831. 039300     05  ANML-GRZG-CD-3929-VU1K                   PIC X(2).
  5832. 039400     05  PUF-3511-VU1K     PIC X(02) OCCURS 5 TIMES.
  5833. 039500     05  PLANT-TYP-3590-VU1K   PIC X.
  5834. 039600     05  FILLER                    PIC X(8).
  5835. 039700 01  V61K-RCD.
  5836. 039800     05  KEY-V61K.
  5837. 039900         10  DIC-V61K.
  5838. 040000             15  REC-TYP-3529-V61K                PIC X(2).
  5839. 040100             15  FMT-NUM-3576-V61K                PIC X(1).
  5840. 040200             15  FMT-CD-3579-V61K                 PIC X(1).
  5841. 040300         10  BLM-ADM-U-0003-V61K.
  5842. 040400             15  BLM-ADM-U-0003-ST-V61K           PIC X(2).
  5843. 040500             15  BLM-ADM-U-0003-DIST-V61K         PIC X(2).
  5844. 040600             15  BLM-ADM-U-0003-RA-V61K           PIC X(2).
  5845. 040700             15  BLM-ADM-U-0003-PLU-V61K          PIC X(2).
  5846. 040800         10  DATA-DATE-6618-V61K.
  5847. 040900             15  DATA-DATE-6618-YY-V61K           PIC X(2).
  5848. 041000         15  DATA-DATE-MM-6618-V61K     PIC XX.
  5849. 041100             15  DATA-DATE-6618-DD-V61K           PIC X(2).
  5850. 041200         10  ACTN-CD-7350-V61K                    PIC X(1).
  5851. 041300         10  LIN-NUM-3578-V61K                    PIC X(4).
  5852. 041400     05  PLANT-CD-2646-V61K                       PIC X(7).
  5853. 041500     05  PHNO-STG-CD-3712-V61K                    PIC X(1).
  5854. 041600     05  GRAMS-GRN-WGT-3941-V61K                  PIC X(4).
  5855. 041700     05  ADW-PCT-3546-V61K                        PIC X(3).
  5856. 041800     05  GRAMS-DRY-WGT-3942-V61K                  PIC X(4).
  5857. 041900     05  GRP-1-V61K.
  5858. 042000         07  BASAL-DIMS-3533-MIN-V61K                 PIC XXXX.
  5859. 042100         07  BASAL-DIMS-3533-MAX-V61K                 PIC XXXX.
  5860. 042200         07  CROWN-DIMS-3534-MIN-V61K                 PIC XXX.
  5861. 042300         07  CROWN-DIMS-3534-MAX-V61K                 PIC XXX.
  5862. 042400         07  HGT-AVG-3504-V61K                        PIC XXXX.
  5863. 042500         07  AVG-LDR-LGT-7313-V61K                    PIC XXX.
  5864. 042600     05  PLANT-TYP-3590-V61K   PIC X.
  5865. 042700     05  REC-CNT-V61K    PIC 99.
  5866. 042800 PROCEDURE DIVISION.
  5867. 042900 000-DRIVER SECTION.
  5868. 043000 010-MAINLINE.
  5869. 043100     PERFORM 100-INITIALIZE.
  5870. 043200     PERFORM 200-SORT.
  5871. 043300     PERFORM 990-TERMINATE.
  5872. 043400     STOP RUN.
  5873. 043500*
  5874. 043600 100-INITIALIZE SECTION.
  5875. 043700 110-OPENS.
  5876. 043800     OPEN INPUT PREV-FILE TRAN-FILE
  5877. 043900          OUTPUT NEW-FILE.
  5878. 044000     MOVE ALL "9" TO PREV-CTL.
  5879. 044100     ACCEPT TODAYS-DATE FROM DATE.
  5880. 044200     ACCEPT PARAMETER.
  5881. 044300*
  5882. 044400 200-SORT SECTION.
  5883. 044500 210-SORT-VERB.
  5884. 044600     SORT SORT-WORK
  5885. 044700             ASCENDING KEY SR-KEY
  5886. 044800             INPUT PROCEDURE 300-READ-FORMAT
  5887. 044900             OUTPUT PROCEDURE 400-MATCH-UPDATE.
  5888. 045000*
  5889. 045100 300-READ-FORMAT SECTION.
  5890. 045200 310-READ.
  5891. 045300     READ TRAN-FILE
  5892. 045400         AT END GO TO 300-EXIT.
  5893. 045500     IF REC-TYP-TF NOT = "VP" AND "VU" AND "VF" AND "V6"
  5894. 045600         DISPLAY "BAD-RCD= " TF-RCD
  5895. 045700         GO TO 310-READ.
  5896. 045800     IF ACTN-TF = SPACE
  5897. 045900         MOVE "A" TO ACTN-TF.
  5898. 046000     IF (REC-TYP-TF = "VU") AND
  5899. 046100          ((LINE-VU-TF NOT NUMERIC) OR
  5900. 046200         (LINE-VU-TF = "0000")
  5901. 046300         OR (RELINE-CHK = "YES"))
  5902. 046400             MOVE ALL "9" TO LINE-VU-TF.
  5903. 046500     IF (REC-TYP-TF NOT = "VU") AND
  5904. 046600          ((LINE-TF NOT NUMERIC) OR
  5905. 046700         (LINE-TF = "0000")
  5906. 046800         OR (RELINE-CHK = "YES"))
  5907. 046900             MOVE ALL "9" TO LINE-TF.
  5908. 047000     MOVE TF-RCD TO REC-HLD-SR.
  5909. 047100     MOVE SPACE TO SR-KEY.
  5910. 047200     MOVE REC-TYP-TF TO REC-TYP-SR.
  5911. 047300     MOVE REC-NUM-CD-TF TO REC-NUM-CD-SR.
  5912. 047400     MOVE SDRP-TF TO SDRP-SR.
  5913. 047500     IF REC-TYP-TF = "VU"
  5914. 047600         MOVE LINE-VU-TF TO LINE-SR
  5915. 047700         MOVE PLANT-CD-VU-TF TO PLANT-CD-SR
  5916. 047800         MOVE ANML-GZ-CD-VU-TF TO ANML-GZ-CD-SR
  5917. 047900         ELSE
  5918. 048000         MOVE LINE-TF TO LINE-SR.
  5919. 048100     IF REC-TYP-TF = "VP" OR "V6"
  5920. 048200         MOVE PLANT-CD-TF TO PLANT-CD-SR
  5921. 048300         MOVE PHNO-STG-TF TO PHNO-STG-SR.
  5922. 048400     IF REC-TYP-TF = "VF"
  5923. 048500         MOVE ANML-GZ-CD-VF-TF TO ANML-GZ-CD-SR.
  5924. 048600     RELEASE SORT-RCD.
  5925. 048700     GO TO 310-READ.
  5926. 048800 300-EXIT.
  5927. 048900     EXIT.
  5928. 049000*
  5929. 049100 400-MATCH-UPDATE SECTION.
  5930. 049200 410-GET-FIRST-RCDS.
  5931. 049300     PERFORM 430-RETURN-SORT.
  5932. 049400     PERFORM 440-READ-PREV.
  5933. 049500 420-COMPARE.
  5934. 049600     IF TRAN-CTL IS EQUAL TO ALL "9" AND
  5935. 049700        PREV-CTL IS EQUAL TO ALL "9"
  5936. 049800             GO TO 400-EXIT.
  5937. 049900     IF TRAN-CTL IS GREATER THAN PREV-CTL
  5938. 050000             PERFORM 500-NO-TRAN
  5939. 050100             GO TO 420-COMPARE.
  5940. 050200     IF PREV-CTL IS GREATER THAN TRAN-CTL
  5941. 050300             PERFORM 600-NO-PREV
  5942. 050400             GO TO 420-COMPARE.
  5943. 050500     IF TRAN-CTL IS EQUAL TO PREV-CTL
  5944. 050600             PERFORM 700-MATCH.
  5945. 050700     GO TO 420-COMPARE.
  5946. 050800 430-RETURN-SORT.
  5947. 050900     RETURN SORT-WORK AT END
  5948. 051000             MOVE "X" TO END-OF-TRAN.
  5949. 051100     IF REC-TYP-SR IS EQUAL TO "VF"
  5950. 051200             MOVE REC-HLD-SR TO VF1K-RCD.
  5951. 051300     IF REC-TYP-SR IS EQUAL TO "VP"
  5952. 051400             MOVE REC-HLD-SR TO VP1K-RCD.
  5953. 051500     IF REC-TYP-SR IS EQUAL TO "VU"
  5954. 051600             MOVE REC-HLD-SR TO VU1K-RCD.
  5955. 051700     IF REC-TYP-SR IS EQUAL TO "V6"
  5956. 051800             MOVE REC-HLD-SR TO V61K-RCD.
  5957. 051900     MOVE SR-KEY TO TRAN-CTL.
  5958. 052000     IF END-OF-TRAN IS EQUAL TO "X"
  5959. 052100             MOVE ALL "9" TO TRAN-CTL.
  5960. 052200 440-READ-PREV.
  5961. 052300     READ PREV-FILE AT END
  5962. 052400             MOVE "X" TO END-OF-PREV.
  5963. 052500     MOVE DIC-VF1X TO RECD-ID-PC.
  5964. 052600     MOVE BLM-ADM-U-0003-VF1X TO SDRP-PC.
  5965. 052700     MOVE LIN-NUM-3578-VF1X TO LINE-PC.
  5966. 052800     IF REC-TYP-3529-VP1X = "VU"
  5967. 052900             MOVE LIN-NUM-3578-VU1X TO LINE-PC.
  5968. 053000     IF END-OF-PREV = "X"
  5969. 053100             MOVE ALL "9" TO PREV-CTL.
  5970. 053200 500-NO-TRAN.
  5971. 053300     MOVE VF1X-RCD     TO VF1Z-RCD.
  5972. 053400     PERFORM 800-ADD-TO-CTRS.
  5973. 053500     PERFORM 920-WRITE-Z-RCD.
  5974. 053600     IF END-OF-PREV NOT = "X"
  5975. 053700     PERFORM 440-READ-PREV.
  5976. 053800 600-NO-PREV.
  5977. 053900     MOVE REC-HLD-SR      TO VF1Z-RCD.
  5978. 054000     PERFORM 800-ADD-TO-CTRS.
  5979. 054100     IF REC-TYP-3529-VF1Z = "VF"
  5980. 054200             PERFORM 810-BUILD-VF-LIN-NUM
  5981. 054300             PERFORM 830-CHECK-VF-LIN-NUM THRU 830-OUT.
  5982. 054400     IF REC-TYP-3529-VF1Z = "VP"
  5983. 054500             PERFORM 820-BUILD-VP-LIN-NUM
  5984. 054600             PERFORM 840-CHECK-VP-LIN-NUM THRU 840-OUT.
  5985. 054700     IF REC-TYP-3529-VF1Z = "VU"
  5986. 054800             PERFORM 815-BUILD-VU-LIN-NUM
  5987. 054900             PERFORM 825-CHECK-VU-LIN-NUM THRU 825-OUT.
  5988. 055000     IF REC-TYP-3529-VF1Z = "V6"
  5989. 055100             PERFORM 835-BUILD-V6-LIN-NUM
  5990. 055200             PERFORM 845-CHECK-V6-LIN-NUM THRU 845-OUT.
  5991. 055300     PERFORM 890-EDIT-DATE.
  5992. 055400     PERFORM 920-WRITE-Z-RCD.
  5993. 055500     IF END-OF-TRAN NOT = "X"
  5994. 055600     PERFORM 430-RETURN-SORT.
  5995. 055700 700-MATCH.
  5996. 055800     MOVE VF1X-RCD     TO VF1Z-RCD.
  5997. 055900     PERFORM 890-EDIT-DATE.
  5998. 056000     IF (DATA-V6FP-SR NOT = SPACES)
  5999. 056100         AND (REC-TYP-3529-VF1Z = "VF")
  6000. 056200             PERFORM 850-MOVE-VF-FIELDS
  6001. 056300             PERFORM 810-BUILD-VF-LIN-NUM
  6002. 056400             PERFORM 800-ADD-TO-CTRS
  6003. 056500             PERFORM 920-WRITE-Z-RCD.
  6004. 056600     IF (DATA-V6FP-SR NOT = SPACES)
  6005. 056700         AND (REC-TYP-3529-VF1Z = "VP")
  6006. 056800             PERFORM 860-MOVE-VP1-FIELDS
  6007. 056900             PERFORM 820-BUILD-VP-LIN-NUM
  6008. 057000             PERFORM 800-ADD-TO-CTRS
  6009. 057100             PERFORM 920-WRITE-Z-RCD.
  6010. 057200     IF (DATA-VU-SR NOT = SPACES)
  6011. 057300         AND (REC-TYP-3529-VF1Z = "VU" )
  6012. 057400             PERFORM 870-MOVE-VU1-FIELDS
  6013. 057500             PERFORM 815-BUILD-VU-LIN-NUM
  6014. 057600             PERFORM 800-ADD-TO-CTRS
  6015. 057700             PERFORM 920-WRITE-Z-RCD.
  6016. 057800     IF (DATA-V6FP-SR NOT = SPACES)
  6017. 057900         AND (REC-TYP-3529-VF1Z = "V6")
  6018. 058000             PERFORM 880-MOVE-V61-FIELDS
  6019. 058100             PERFORM 835-BUILD-V6-LIN-NUM
  6020. 058200             PERFORM 800-ADD-TO-CTRS
  6021. 058300             PERFORM 920-WRITE-Z-RCD.
  6022. 058400     IF END-OF-TRAN NOT = "X"
  6023. 058500     PERFORM 430-RETURN-SORT.
  6024. 058600     IF END-OF-PREV NOT = "X"
  6025. 058700     PERFORM 440-READ-PREV.
  6026. 058800*
  6027. 058900 800-ADD-TO-CTRS.
  6028. 059000     IF REC-TYP-3529-VF1Z = "VF"
  6029. 059100             ADD 1 TO VF1-CTR
  6030. 059200             PERFORM 810-BUILD-VF-LIN-NUM.
  6031. 059300     IF REC-TYP-3529-VF1Z = "VP"
  6032. 059400             PERFORM 820-BUILD-VP-LIN-NUM
  6033. 059500             ADD 1 TO VP1-CTR.
  6034. 059600     IF REC-TYP-3529-VF1Z = "VU"
  6035. 059700             PERFORM 815-BUILD-VU-LIN-NUM
  6036. 059800             ADD 1 TO VU1-CTR.
  6037. 059900     IF REC-TYP-3529-VF1Z = "V6"
  6038. 060000             PERFORM 835-BUILD-V6-LIN-NUM
  6039. 060100             ADD 1 TO V61-CTR.
  6040. 060200*
  6041. 060300 810-BUILD-VF-LIN-NUM.
  6042. 060400     IF (LIN-NUM-3578-VF1Z NOT NUMERIC) OR
  6043. 060500        (LIN-NUM-3578-VF1Z = "0000")
  6044. 060600             MOVE "9999" TO LIN-NUM-3578-VF1Z.
  6045. 060700 815-BUILD-VU-LIN-NUM.
  6046. 060800     IF (LIN-NUM-3578-VU1Z NOT NUMERIC) OR
  6047. 060900        (LIN-NUM-3578-VU1Z = "0000")
  6048. 061000             MOVE "9999" TO LIN-NUM-3578-VU1Z.
  6049. 061100 820-BUILD-VP-LIN-NUM.
  6050. 061200     IF (LIN-NUM-3578-VP1Z NOT NUMERIC) OR
  6051. 061300        (LIN-NUM-3578-VP1Z = "0000")
  6052. 061400             MOVE "9999" TO LIN-NUM-3578-VP1Z.
  6053. 061500 825-CHECK-VU-LIN-NUM.
  6054. 061600     IF LIN-NUM-3578-VU1Z NOT = "9999"
  6055. 061700             GO TO 825-OUT.
  6056. 061800     MOVE DIC-VF1Z TO RECD-ID-C.
  6057. 061900     MOVE BLM-ADM-U-0003-VF1Z TO SDRP-C.
  6058. 062000     IF CTL NOT =  CTL-SAVE
  6059. 062100             MOVE 0001 TO LAST-LIN-NUM
  6060. 062200             MOVE "0001" TO LIN-NUM-3578-VU1Z
  6061. 062300       ELSE  ADD 1 TO LAST-LIN-NUM
  6062. 062400             MOVE LAST-LIN-NUM TO LIN-NUM-3578-VU1Z.
  6063. 062500     MOVE CTL TO CTL-SAVE.
  6064. 062600 825-OUT.
  6065. 062700     EXIT.
  6066. 062800 830-CHECK-VF-LIN-NUM.
  6067. 062900     IF LIN-NUM-3578-VF1Z NOT = ALL "9"
  6068. 063000             GO TO 830-OUT.
  6069. 063100     MOVE DIC-VF1Z TO RECD-ID-C.
  6070. 063200     MOVE BLM-ADM-U-0003-VF1Z TO SDRP-C.
  6071. 063300     IF CTL NOT = CTL-SAVE
  6072. 063400             MOVE 0001 TO LAST-LIN-NUM
  6073. 063500             MOVE "0001" TO LIN-NUM-3578-VF1Z
  6074. 063600       ELSE
  6075. 063700             ADD 1     TO LAST-LIN-NUM
  6076. 063800             MOVE LAST-LIN-NUM TO LIN-NUM-3578-VF1Z.
  6077. 063900     MOVE CTL TO CTL-SAVE.
  6078. 064000 830-OUT.
  6079. 064100     EXIT.
  6080. 064200 835-BUILD-V6-LIN-NUM.
  6081. 064300     IF (LIN-NUM-3578-V61Z NOT NUMERIC) OR
  6082. 064400        (LIN-NUM-3578-V61Z = "0000")
  6083. 064500             MOVE "9999" TO LIN-NUM-3578-V61Z.
  6084. 064600 840-CHECK-VP-LIN-NUM.
  6085. 064700     IF LIN-NUM-3578-VP1Z NOT = ALL "9"
  6086. 064800             GO TO 840-OUT.
  6087. 064900     MOVE DIC-VP1Z TO RECD-ID-C.
  6088. 065000     MOVE BLM-ADM-U-0003-VP1Z TO SDRP-C.
  6089. 065100     IF CTL NOT = CTL-SAVE
  6090. 065200             MOVE 0001 TO LAST-LIN-NUM
  6091. 065300             MOVE "0001" TO LIN-NUM-3578-VP1Z
  6092. 065400       ELSE
  6093. 065500             ADD 1 TO LAST-LIN-NUM
  6094. 065600             MOVE LAST-LIN-NUM TO LIN-NUM-3578-VP1Z.
  6095. 065700     MOVE CTL TO CTL-SAVE.
  6096. 065800 840-OUT.
  6097. 065900     EXIT.
  6098. 066000 845-CHECK-V6-LIN-NUM.
  6099. 066100     IF LIN-NUM-3578-V61Z NOT = "9999"
  6100. 066200             GO TO 845-OUT.
  6101. 066300     MOVE DIC-VF1Z TO RECD-ID-C.
  6102. 066400     MOVE BLM-ADM-U-0003-VF1Z TO SDRP-C.
  6103. 066500     IF CTL NOT = TO CTL-SAVE
  6104. 066600             MOVE 0001 TO LAST-LIN-NUM
  6105. 066700             MOVE "0001" TO LIN-NUM-3578-V61Z
  6106. 066800       ELSE  ADD 1 TO LAST-LIN-NUM
  6107. 066900             MOVE LAST-LIN-NUM TO LIN-NUM-3578-V61Z.
  6108. 067000     MOVE CTL TO CTL-SAVE.
  6109. 067100 845-OUT.
  6110. 067200     EXIT.
  6111. 067300*
  6112. 067400 850-MOVE-VF-FIELDS.
  6113. 067500     IF ANML-GRZG-CD-3929-VF1K       = SPACES
  6114. 067600             NEXT SENTENCE
  6115. 067700       ELSE
  6116. 067800           IF ANML-GRZG-CD-3929-VF1K       = "**"
  6117. 067900                  MOVE SPACES TO ANML-GRZG-CD-3929-VF1Z
  6118. 068000                ELSE
  6119. 068100        MOVE ANML-GRZG-CD-3929-VF1K TO ANML-GRZG-CD-3929-VF1Z.
  6120. 068200     IF MON-FORG-RQMT-LBS-3551-VF1K = SPACES
  6121. 068300             NEXT SENTENCE
  6122. 068400             ELSE
  6123. 068500             IF MON-FORG-RQMT-LBS-3551-VF1K = "**"
  6124. 068600                  MOVE SPACES TO MON-FORG-RQMT-LBS-3551-VF1Z
  6125. 068700                  MOVE MON-FORG-RQMT-LBS-3551-VF1K TO
  6126. 068800                       MON-FORG-RQMT-LBS-3551-VF1Z.
  6127. 068900     IF ANML-HGT-CLS-CD-3548-VF1K = SPACES
  6128. 069000             NEXT SENTENCE
  6129. 069100             ELSE
  6130. 069200             IF ANML-HGT-CLS-CD-3548-VF1K = "*"
  6131. 069300                  MOVE SPACES TO ANML-HGT-CLS-CD-3548-VF1Z
  6132. 069400                  ELSE
  6133. 069500      MOVE ANML-HGT-CLS-CD-3548-VF1K TO ANML-HGT-CLS-CD-3548-VF1Z.
  6134. 069600 870-MOVE-VU1-FIELDS.
  6135. 069700     IF PLANT-CD-2646-VU1K = SPACES
  6136. 069800             NEXT SENTENCE
  6137. 069900             ELSE
  6138. 070000             IF PLANT-CD-2646-VU1K = "*******"
  6139. 070100                  MOVE SPACES TO PLANT-CD-2646-VU1Z
  6140. 070200                  ELSE
  6141. 070300                  MOVE PLANT-CD-2646-VU1K TO PLANT-CD-2646-VU1Z.
  6142. 070400     IF AUF-3928-VU1K (1) = SPACES
  6143. 070500             NEXT SENTENCE
  6144. 070600             ELSE
  6145. 070700             IF AUF-3928-VU1K (1) = "**"
  6146. 070800                  MOVE SPACES TO AUF-3928-VU1Z (1)
  6147. 070900                  ELSE
  6148. 071000                  MOVE AUF-3928-VU1K (1) TO AUF-3928-VU1Z (1).
  6149. 071100     IF AUF-3928-VU1K (2) = SPACES
  6150. 071200             NEXT SENTENCE
  6151. 071300             ELSE
  6152. 071400             IF AUF-3928-VU1K (2) = "**"
  6153. 071500                  MOVE SPACES TO AUF-3928-VU1Z (2)
  6154. 071600                  ELSE
  6155. 071700                  MOVE AUF-3928-VU1K (2) TO AUF-3928-VU1Z (2).
  6156. 071800     IF AUF-3928-VU1K (3) = SPACES
  6157. 071900             NEXT SENTENCE
  6158. 072000             ELSE
  6159. 072100             IF AUF-3928-VU1K (3) = "**"
  6160. 072200                  MOVE SPACES TO AUF-3928-VU1Z (3)
  6161. 072300                  ELSE
  6162. 072400                  MOVE AUF-3928-VU1K (3) TO AUF-3928-VU1Z (3).
  6163. 072500     IF AUF-3928-VU1K (4) = SPACES
  6164. 072600             NEXT SENTENCE
  6165. 072700             ELSE
  6166. 072800             IF AUF-3928-VU1K (4) = "**"
  6167. 072900                  MOVE SPACES TO AUF-3928-VU1Z (4)
  6168. 073000                  ELSE
  6169. 073100                  MOVE AUF-3928-VU1K (4)  TO AUF-3928-VU1Z (4).
  6170. 073200     IF AUF-3928-VU1K (5) = SPACES
  6171. 073300             NEXT SENTENCE
  6172. 073400             ELSE
  6173. 073500             IF AUF-3928-VU1K (5)  = "**"
  6174. 073600                  MOVE SPACES TO AUF-3928-VU1Z (5)
  6175. 073700                  ELSE
  6176. 073800                  MOVE AUF-3928-VU1K (5) TO AUF-3928-VU1Z (5).
  6177. 073900     IF ANML-GRZG-CD-3929-VU1K = SPACES
  6178. 074000             NEXT SENTENCE
  6179. 074100             ELSE
  6180. 074200             IF ANML-GRZG-CD-3929-VU1K = "**"
  6181. 074300                  MOVE SPACES TO ANML-GRZG-CD-3929-VU1Z
  6182. 074400                  ELSE
  6183. 074500        MOVE ANML-GRZG-CD-3929-VU1K TO ANML-GRZG-CD-3929-VU1Z.
  6184. 074600     IF PUF-3511-VU1K (1) = SPACES
  6185. 074700             NEXT SENTENCE
  6186. 074800             ELSE
  6187. 074900             IF PUF-3511-VU1K (1) = "**"
  6188. 075000                  MOVE SPACES TO PUF-3511-VU1Z (1)
  6189. 075100                  ELSE
  6190. 075200                  MOVE PUF-3511-VU1K (1) TO PUF-3511-VU1Z (1).
  6191. 075300     IF PUF-3511-VU1K (2) = SPACES
  6192. 075400             NEXT SENTENCE
  6193. 075500             ELSE
  6194. 075600             IF PUF-3511-VU1K (2) = "**"
  6195. 075700                  MOVE SPACES TO PUF-3511-VU1Z (2)
  6196. 075800                  ELSE
  6197. 075900                  MOVE PUF-3511-VU1K (2) TO PUF-3511-VU1Z (2).
  6198. 076000     IF PUF-3511-VU1K (3) = SPACES
  6199. 076100             NEXT SENTENCE
  6200. 076200             ELSE
  6201. 076300             IF PUF-3511-VU1K (3) = "**"
  6202. 076400                  MOVE SPACES TO PUF-3511-VU1Z (3)
  6203. 076500                  ELSE
  6204. 076600                  MOVE PUF-3511-VU1K (3) TO PUF-3511-VU1Z (3).
  6205. 076700     IF PUF-3511-VU1K (4) = SPACES
  6206. 076800             NEXT SENTENCE
  6207. 076900             ELSE
  6208. 077000             IF PUF-3511-VU1K (4) = "**"
  6209. 077100                  MOVE SPACES TO PUF-3511-VU1Z (4)
  6210. 077200                  ELSE
  6211. 077300                  MOVE PUF-3511-VU1K (4) TO PUF-3511-VU1Z (4).
  6212. 077400     IF PUF-3511-VU1K (5) = SPACES
  6213. 077500             NEXT SENTENCE
  6214. 077600             ELSE
  6215. 077700             IF PUF-3511-VU1K (5) = "**"
  6216. 077800                  MOVE SPACES TO PUF-3511-VU1Z (5)
  6217. 077900                  ELSE
  6218. 078000                  MOVE PUF-3511-VU1K (5) TO PUF-3511-VU1Z (5).
  6219. 078100 860-MOVE-VP1-FIELDS.
  6220. 078200     IF PLANT-TYP-3590-VP1K  = SPACES
  6221. 078300             NEXT SENTENCE
  6222. 078400             ELSE
  6223. 078500             IF PLANT-TYP-3590-VP1K  = "*"
  6224. 078600                 MOVE SPACES TO PLANT-TYP-3590-VP1Z
  6225. 078700                 ELSE
  6226. 078800                 MOVE PLANT-TYP-3590-VP1K  TO
  6227. 078900                      PLANT-TYP-3590-VP1Z.
  6228. 079000     IF PLANT-CD-2646-VP1K = SPACES
  6229. 079100             NEXT SENTENCE
  6230. 079200             ELSE
  6231. 079300             IF PLANT-CD-2646-VP1K = "*******"
  6232. 079400                 MOVE SPACES TO PLANT-CD-2646-VP1Z
  6233. 079500                 ELSE
  6234. 079600       MOVE PLANT-CD-2646-VP1K TO PLANT-CD-2646-VP1Z.
  6235. 079700     IF PHNO-ADJ-VP1K (1) = SPACES
  6236. 079800             NEXT SENTENCE
  6237. 079900             ELSE
  6238. 080000             IF PHNO-ADJ-VP1K (1) = "****"
  6239. 080100                 MOVE SPACES TO PHNO-ADJ-VP1Z (1)
  6240. 080200                 ELSE
  6241. 080300                 MOVE PHNO-ADJ-VP1K (1) TO
  6242. 080400                      PHNO-ADJ-VP1Z (1).
  6243. 080500     IF PHNO-ADJ-VP1K (2) = SPACES
  6244. 080600             NEXT SENTENCE
  6245. 080700             ELSE
  6246. 080800             IF PHNO-ADJ-VP1K (2) = "****"
  6247. 080900                 MOVE SPACES TO PHNO-ADJ-VP1Z (2)
  6248. 081000                 ELSE
  6249. 081100                 MOVE PHNO-ADJ-VP1K (2) TO
  6250. 081200                      PHNO-ADJ-VP1Z (2).
  6251. 081300     IF PHNO-ADJ-VP1K (3) = SPACES
  6252. 081400             NEXT SENTENCE
  6253. 081500             ELSE
  6254. 081600             IF PHNO-ADJ-VP1K (3) = "****"
  6255. 081700                 MOVE SPACES TO PHNO-ADJ-VP1Z (3)
  6256. 081800                 ELSE
  6257. 081900                 MOVE PHNO-ADJ-VP1K (3) TO
  6258. 082000                      PHNO-ADJ-VP1Z (3).
  6259. 082100     IF PHNO-ADJ-VP1K (4) = SPACES
  6260. 082200             NEXT SENTENCE
  6261. 082300             ELSE
  6262. 082400             IF PHNO-ADJ-VP1K (4) = "****"
  6263. 082500                 MOVE SPACES TO PHNO-ADJ-VP1Z (4)
  6264. 082600                 ELSE
  6265. 082700                 MOVE PHNO-ADJ-VP1K (4) TO
  6266. 082800                      PHNO-ADJ-VP1Z (4).
  6267. 082900     IF PHNO-ADJ-VP1K (5) = SPACES
  6268. 083000             NEXT SENTENCE
  6269. 083100             ELSE
  6270. 083200             IF PHNO-ADJ-VP1K (5) = "****"
  6271. 083300                 MOVE SPACES TO PHNO-ADJ-VP1Z (5)
  6272. 083400                 ELSE
  6273. 083500                 MOVE PHNO-ADJ-VP1K (5) TO
  6274. 083600                      PHNO-ADJ-VP1Z (5).
  6275. 083700 880-MOVE-V61-FIELDS.
  6276. 083800     IF PLANT-CD-2646-V61K   = SPACES
  6277. 083900             NEXT SENTENCE
  6278. 084000             ELSE
  6279. 084100             IF PLANT-CD-2646-V61K   = "*****"
  6280. 084200                 MOVE SPACES TO PLANT-CD-2646-V61Z
  6281. 084300                 ELSE
  6282. 084400       MOVE PLANT-CD-2646-V61K TO PLANT-CD-2646-V61Z.
  6283. 084500     IF PHNO-STG-CD-3712-V61K   = SPACES
  6284. 084600             NEXT SENTENCE
  6285. 084700             ELSE
  6286. 084800             IF PHNO-STG-CD-3712-V61K   = "*"
  6287. 084900                 MOVE SPACES TO PHNO-STG-CD-3712-V61Z
  6288. 085000                 ELSE
  6289. 085100       MOVE PHNO-STG-CD-3712-V61K   TO PHNO-STG-CD-3712-V61Z.
  6290. 085200     IF GRAMS-GRN-WGT-3941-V61K   = SPACES
  6291. 085300             NEXT SENTENCE
  6292. 085400             ELSE
  6293. 085500             IF GRAMS-GRN-WGT-3941-V61K   = "****"
  6294. 085600                 MOVE SPACES TO GRAMS-GRN-WGT-3941-V61Z
  6295. 085700                 ELSE
  6296. 085800       MOVE GRAMS-GRN-WGT-3941-V61K   TO GRAMS-GRN-WGT-3941-V61Z.
  6297. 085900     IF ADW-PCT-3546-V61K   = SPACES
  6298. 086000             NEXT SENTENCE
  6299. 086100             ELSE
  6300. 086200             IF ADW-PCT-3546-V61K   = "***"
  6301. 086300                 MOVE SPACES TO ADW-PCT-3546-V61Z
  6302. 086400                 ELSE
  6303. 086500       MOVE ADW-PCT-3546-V61K   TO ADW-PCT-3546-V61Z.
  6304. 086600     IF BASAL-DIMS-3533-MIN-V61K   = SPACES
  6305. 086700             NEXT SENTENCE
  6306. 086800             ELSE
  6307. 086900             IF BASAL-DIMS-3533-MIN-V61K   = "****"
  6308. 087000                 MOVE SPACES TO BASAL-DIMS-3533-MIN-V61Z
  6309. 087100                 ELSE
  6310. 087200       MOVE BASAL-DIMS-3533-MIN-V61K   TO BASAL-DIMS-3533-MIN-V61Z
  6311. 087300     IF BASAL-DIMS-3533-MAX-V61K   = SPACES
  6312. 087400             NEXT SENTENCE
  6313. 087500             ELSE
  6314. 087600             IF BASAL-DIMS-3533-MAX-V61K   = "****"
  6315. 087700                 MOVE SPACES TO BASAL-DIMS-3533-MAX-V61Z
  6316. 087800                 ELSE
  6317. 087900       MOVE BASAL-DIMS-3533-MAX-V61K   TO BASAL-DIMS-3533-MAX-V61Z
  6318. 088000     IF CROWN-DIMS-3534-MIN-V61K   = SPACES
  6319. 088100             NEXT SENTENCE
  6320. 088200             ELSE
  6321. 088300             IF CROWN-DIMS-3534-MIN-V61K   = "***"
  6322. 088400                 MOVE SPACES TO CROWN-DIMS-3534-MIN-V61Z
  6323. 088500                 ELSE
  6324. 088600       MOVE CROWN-DIMS-3534-MIN-V61K   TO CROWN-DIMS-3534-MIN-V61Z
  6325. 088700     IF CROWN-DIMS-3534-MAX-V61K   = SPACES
  6326. 088800             NEXT SENTENCE
  6327. 088900             ELSE
  6328. 089000             IF CROWN-DIMS-3534-MAX-V61K   = "***"
  6329. 089100                 MOVE SPACES TO CROWN-DIMS-3534-MAX-V61Z
  6330. 089200                 ELSE
  6331. 089300       MOVE CROWN-DIMS-3534-MAX-V61K   TO CROWN-DIMS-3534-MAX-V61Z
  6332. 089400     IF HGT-AVG-3504-V61K   = SPACES
  6333. 089500             NEXT SENTENCE
  6334. 089600             ELSE
  6335. 089700             IF HGT-AVG-3504-V61K   = "****"
  6336. 089800                 MOVE SPACES TO HGT-AVG-3504-V61Z
  6337. 089900                 ELSE
  6338. 090000                 MOVE HGT-AVG-3504-V61K   TO HGT-AVG-3504-V61Z.
  6339. 090100     IF AVG-LDR-LGT-7313-V61K   = SPACES
  6340. 090200             NEXT SENTENCE
  6341. 090300             ELSE
  6342. 090400             IF AVG-LDR-LGT-7313-V61K   = "***"
  6343. 090500                 MOVE SPACES TO AVG-LDR-LGT-7313-V61Z
  6344. 090600                 ELSE
  6345. 090700            MOVE AVG-LDR-LGT-7313-V61K   TO AVG-LDR-LGT-7313-V61Z.
  6346. 090800     IF PLANT-CD-2646-V61K   = SPACES
  6347. 090900             NEXT SENTENCE
  6348. 091000             ELSE
  6349. 091100             IF PLANT-CD-2646-V61K   = "*****"
  6350. 091200                 MOVE SPACES TO PLANT-CD-2646-V61Z
  6351. 091300                 ELSE
  6352. 091400                 MOVE PLANT-CD-2646-V61K   TO PLANT-CD-2646-V61Z.
  6353. 091500     MOVE REC-CNT-V61K TO REC-CNT-V61Z.
  6354. 091600*
  6355. 091700 890-EDIT-DATE.
  6356. 091800     MOVE SPACE TO DATE-MV-SW.
  6357. 091900     MOVE DATA-DATE-6618-VP1Z TO DATE-WORK.
  6358. 092000     PERFORM 900-EDIT-FIELDS.
  6359. 092100     IF DATE-SW NOT = " "
  6360. 092200             PERFORM 910-SWITCH-FIELDS
  6361. 092300             PERFORM 900-EDIT-FIELDS.
  6362. 092400     IF DATE-SW NOT = " "
  6363. 092500             MOVE TODAYS-DATE TO DATA-DATE-6618-VF1Z.
  6364. 092600     IF DATE-MV-SW NOT = " "
  6365. 092700             MOVE MOVED-DATE  TO DATA-DATE-6618-VF1Z.
  6366. 092800 900-EDIT-FIELDS.
  6367. 092900     MOVE SPACE TO DATE-SW.
  6368. 093000     IF DW-MM NOT NUMERIC OR
  6369. 093100        DW-MM > "12"      OR
  6370. 093200        DW-MM < "01"
  6371. 093300             MOVE "X" TO DATE-SW.
  6372. 093400     IF DW-DD NOT NUMERIC OR
  6373. 093500        DW-DD < "01"      OR
  6374. 093600        DW-DD > "31"
  6375. 093700             MOVE "X" TO DATE-SW.
  6376. 093800     IF DW-YY NOT NUMERIC OR
  6377. 093900        DW-YY < "78"
  6378. 094000             MOVE "X" TO DATE-SW.
  6379. 094100 910-SWITCH-FIELDS.
  6380. 094200     MOVE " " TO DATE-MV-SW.
  6381. 094300     IF DW-DD = "78" OR "79" OR "80" OR "81" OR "82"
  6382. 094400             MOVE DW-MM TO MD-MM
  6383. 094500             MOVE DW-DD TO MD-DD
  6384. 094600             MOVE DW-YY TO MD-YY
  6385. 094700             MOVE "X"   TO DATE-MV-SW.
  6386. 094800 920-WRITE-Z-RCD.
  6387. 094900     MOVE LIN-NUM-3578-VP1Z TO LAST-LIN-NUM.
  6388. 095000     IF REC-TYP-3529-VF1Z = "VU"
  6389. 095100             MOVE LIN-NUM-3578-VU1Z TO LAST-LIN-NUM.
  6390. 095200     MOVE DIC-VP1Z TO RECD-ID-C.
  6391. 095300     MOVE BLM-ADM-U-0003-VP1Z TO SDRP-C.
  6392. 095400     IF REC-TYP-3529-VF1Z = "VF" MOVE SPACES TO OPEN-VF1Z.
  6393. 095500     IF REC-TYP-3529-VF1Z = "VP" MOVE SPACES TO OPEN-VP1Z.
  6394. 095600     IF REC-TYP-3529-VF1Z = "VU" MOVE SPACES TO OPEN-VU1Z.
  6395. 095700     MOVE CTL TO CTL-SAVE.
  6396. 095800     MOVE "A" TO ACTN-CD-7350-VF1Z.
  6397. 095900     WRITE VF1Z-RCD.
  6398. 096000 400-EXIT.
  6399. 096100     EXIT.
  6400. 096200*
  6401. 096300 990-TERMINATE SECTION.
  6402. 096400 990-PRINT.
  6403. 096500     DISPLAY "  VF1    VP1    VU1    V61".
  6404. 096600     DISPLAY VF1-CTR "  " VP1-CTR "  " VU1-CTR "  " V61-CTR.
  6405. 096700 990-CLOSE.
  6406. 096800     CLOSE PREV-FILE TRAN-FILE NEW-FILE.
  6407. 096900*
  6408. 000000*-----------------------------------------------------------------
  6409. 000100 IDENTIFICATION DIVISION.
  6410. 000200 PROGRAM-ID. ES115P.
  6411. 000300*        V6, VF, VP, VU VERIFICATION LIST
  6412. 000400*
  6413. 000500 AUTHOR. CORA FISCHER.
  6414. 000500 INSTALLATION.
  6415. 000600 DATE-WRITTEN.  7/10/80.
  6416. 000700 DATE-COMPILED.
  6417. 000800 ENVIRONMENT DIVISION.
  6418. 000900 CONFIGURATION SECTION.
  6419. 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
  6420. 001100 OBJECT-COMPUTER. LEVEL-66-ASCII.
  6421. 001200 INPUT-OUTPUT SECTION.
  6422. 001300 FILE-CONTROL.
  6423. 001400     SELECT  INPUT-FILE1 ASSIGN TO I1-ES110UD1
  6424. 001500         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  6425. 001600     SELECT  OPTIONAL INPUT-FILE2 ASSIGN TO I2-ES120UD1
  6426. 001700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  6427. 001800     SELECT  PRINT-FILE ASSIGN TO P1-PRINTER
  6428. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  6429. 002000     SELECT  SORT-FILE ASSIGN TO S1.
  6430. 002100 DATA DIVISION.
  6431. 002200 SUB-SCHEMA SECTION.
  6432. 002300 DB  CODVAL2 WITHIN BLMDIC.
  6433. 002400 FILE SECTION.
  6434. 002500 FD  INPUT-FILE1       CODE-SET IS GBCD
  6435. 002600                       LABEL RECORDS ARE STANDARD
  6436. 002700                       DATA RECORDS ARE FDR-V6  FDR-VF
  6437. 002800                         FDR-VP  FDR-VU.
  6438. 002900 01  FDR-V6.
  6439. 003000     03  REC-TYPE-3529-V6-I1               PIC       X(02).
  6440. 003100     03  FMT-NO-3576-V6-I1                 PIC       X(01).
  6441. 003200     03  FMT-CD-3579-V6-I1                 PIC       X(01).
  6442. 003300     03  ADM-UNIT-0003-V6-I1               PIC       X(08).
  6443. 003400     03  DATA-DT-6618-V6-I1                PIC       X(06).
  6444. 003500     03  ACT-CD-7350-V6-I1                 PIC       X(01).
  6445. 003600     03  LINE-NO-3578-V6-I1                PIC       X(04).
  6446. 003700     03  PLANT-CD-2646-V6-I1               PIC       X(07).
  6447. 003800     03  PHNO-STG-CD-3712-V6-I1            PIC       X(01).
  6448. 003900     03  GRAMS-GRN-WGT-3941-V6-I1          PIC       X(04).
  6449. 004000     03  ADW-PCT-3546-V6-I1                PIC       X(03).
  6450. 004100     03  GRAMS-DRY-WGT-3942-V6-I1          PIC       X(04).
  6451. 004200     03  BASAL-DIMS-3533-V6-I1             PIC       X(08).
  6452. 004300     03  CROWN-DIMS-3534-V6-I1             PIC       X(06).
  6453. 004400     03  HGT-AVG-3504-V6-I1                PIC       X(04).
  6454. 004500     03  AVG-LDR-LGT-7313-V6-I1            PIC       X(03).
  6455. 004600     03  FILLER                            PIC       X(03).
  6456. 004700 01  FDR-VF.
  6457. 004800     03  REC-TYPE-3529-VF-I1               PIC       X(02).
  6458. 004900     03  FMT-NO-3576-VF-I1                 PIC       X(01).
  6459. 005000     03  FMT-CD-3579-VF-I1                 PIC       X(01).
  6460. 005100     03  ADM-UNIT-0003-VF-I1.
  6461. 005200         05  ADM-ST-0003-VF-I1             PIC       X(02).
  6462. 005300         05  ADM-DI-0003-VF-I1             PIC       X(02).
  6463. 005400         05  ADM-RA-0003-VF-I1             PIC       X(02).
  6464. 005500         05  ADM-PU-0003-VF-I1             PIC       X(02).
  6465. 005600     03  DATA-DT-6618-VF-I1                PIC       X(06).
  6466. 005700     03  ACT-CD-7350-VF-I1                 PIC       X(01).
  6467. 005800     03  LINE-NO-3578-VF-I1                PIC       X(04).
  6468. 005900     03  ANML-GRZG-CD-3929-VF-I1           PIC       X(02).
  6469. 006000     03  MON-FORG-RQMT-3551-VF-I1          PIC       X(04).
  6470. 006100     03  ANML-HGT-CLS-CD-3548-VF-I1        PIC       X(01).
  6471. 006200     03  FILLER                            PIC       X(36).
  6472. 006300 01  FDR-VP.
  6473. 006400     03  REC-TYPE-3529-VP-I1               PIC       X(02).
  6474. 006500     03  FMT-NO-3576-VP-I1                 PIC       X(01).
  6475. 006600     03  FMT-CD-3579-VP-I1                 PIC       X(01).
  6476. 006700     03  ADM-UNIT-0003-VP-I1               PIC       X(08).
  6477. 006800     03  DATA-DT-6618-VP-I1                PIC       X(06).
  6478. 006900     03  ACT-CD-7350-VP-I1                 PIC       X(01).
  6479. 007000     03  LINE-NO-3578-VP-I1                PIC       X(04).
  6480. 007100     03  PLANT-CD-2646-VP-I1               PIC       X(07).
  6481. 007200     03  PHNO-ADJ-FCTR-3545-VP-I1 OCCURS 8 TIMES PIC X(04).
  6482. 007300     03  FILLER                            PIC       X(04).
  6483. 007400 01  FDR-VU.
  6484. 007500     03  REC-TYPE-3529-VU-I1               PIC       X(02).
  6485. 007600     03  FMT-NO-3576-VU-I1                 PIC       X(01).
  6486. 007700     03  FMT-CD-3579-VU-I1                 PIC       X(01).
  6487. 007800     03  ADM-UNIT-0003-VU-I1               PIC       X(08).
  6488. 007900     03  DATA-DT-6618-VU-I1                PIC       X(06).
  6489. 008000     03  ACT-CD-7350-VU-I1                 PIC       X(01).
  6490. 008100     03  DUF-3917-VU-I1                    PIC       X(01).
  6491. 008200     03  LINE-NO-3578-VU-I1                PIC       X(04).
  6492. 008300     03  PLANT-CD-2646-VU-I1               PIC       X(07).
  6493. 008400     03  AUF-3928-VU-I1 OCCURS 5 TIMES     PIC       X(03).
  6494. 008500     03  ANML-GRZG-CD-3929-VU-I1           PIC       X(02).
  6495. 008600     03  PUF-3511-VU-I1 OCCURS 5 TIMES     PIC       X(02).
  6496. 008700     03  FILLER                            PIC       X(08).
  6497. 008800 FD  INPUT-FILE2       CODE-SET IS GBCD
  6498. 008900                       LABEL RECORDS ARE STANDARD
  6499. 009000                       DATA RECORD IS FDR-V7.
  6500. 009100 01  FDR-V7.
  6501. 009200     03  REC-TYPE-3529-V7-I1               PIC       X(02).
  6502. 009300     03  FMT-NO-3576-V7-I1                 PIC       X(01).
  6503. 009400     03  FMT-CD-3579-V7-I1                 PIC       X(01).
  6504. 009500     03  ADM-UNIT-0003-V7-I1               PIC       X(08).
  6505. 009600     03  DATA-DT-6618-V7-I1                PIC       X(06).
  6506. 009700     03  ACT-CD-7350-V7-I1                 PIC       X(01).
  6507. 009800     03  LINE-NO-3578-V7-I1                PIC       X(04).
  6508. 009900     03  PLANT-CD-2646-V7-I1 OCCURS 9 TIMES PIC      X(07).
  6509. 010000     03  FILLER                             PIC      X(04).
  6510. 010100 FD  PRINT-FILE        CODE-SET IS GBCD
  6511. 010200                       LABEL RECORDS ARE STANDARD
  6512. 010300                       DATA RECORD IS PRT-REC.
  6513. 010400 01  PRT-REC                               PIC       X(132).
  6514. 010500 SD  SORT-FILE         DATA RECORDS ARE S-KEY1, S-KEY2,
  6515. 010600                                 S-KEY3, S-KEY4, S-KEY5.
  6516. 010700 01  S-KEY1.
  6517. 010800     03  S-KEY1A.
  6518. 010900         05  REC-TYPE-3529-V6-S1           PIC       X(02).
  6519. 011000         05  FMT-NO-3576-V6-S1             PIC       X(01).
  6520. 011100         05  FMT-CD-3579-V6-S1             PIC       X(01).
  6521. 011200         05  ADM-UNIT-0003-V6-S1.
  6522. 011300             10  ADM-ST-0003-V6-S1         PIC       X(02).
  6523. 011400             10  ADM-DI-0003-V6-S1         PIC       X(02).
  6524. 011500             10  ADM-RA-0003-V6-S1         PIC       X(02).
  6525. 011600             10  ADM-PU-0003-V6-S1         PIC       X(02).
  6526. 011700         05  PLANT-CD-2646-V6-S1           PIC       X(07).
  6527. 011800         05  PHNO-STG-CD-3712-V6-S1        PIC       X(01).
  6528. 011900         05  FILLER                        PIC       X(04).
  6529. 012000     03  DATA-DT-6618-V6-S1                PIC       X(06).
  6530. 012100     03  ACT-CD-7350-V6-S1                 PIC       X(01).
  6531. 012200     03  LINE-NO-3578-V6-S1                PIC       X(04).
  6532. 012300     03  GRAMS-GRN-WGT-3941-V6-S1          PIC       X(04).
  6533. 012400     03  ADW-PCT-3546-V6-S1                PIC       X(03).
  6534. 012500     03  GRAMS-DRY-WGT-3942-V6-S1          PIC       X(04).
  6535. 012600     03  BA-DIMS-3533-V6-S1.
  6536. 012700         05  BA-DIMS-MIN-3533-V6-S1        PIC       X(04).
  6537. 012800         05  BA-DIMS-MIN-RE-3533-V6-S1  REDEFINES
  6538. 012900                 BA-DIMS-MIN-3533-V6-S1    PIC       99V99.
  6539. 013000         05  BA-DIMS-MAX-3533-V6-S1        PIC       X(04).
  6540. 013100         05  BA-DIMS-MAX-RE-3533-V6-S1  REDEFINES
  6541. 013200                 BA-DIMS-MAX-3533-V6-S1    PIC       99V99.
  6542. 013300     03  CRN-DIMS-3534-V6-S1.
  6543. 013400         05  CRN-DIMS-MIN-3534-V6-S1       PIC       X(03).
  6544. 013500         05  CRN-DIMS-MIN-RE-3534-V6-S1  REDEFINES
  6545. 013600                CRN-DIMS-MIN-3534-V6-S1    PIC       99V9.
  6546. 013700         05  CRN-DIMS-MAX-3534-V6-S1       PIC       X(03).
  6547. 013800         05  CRN-DIMS-MAX-RE-3534-V6-S1  REDEFINES
  6548. 013900                CRN-DIMS-MAX-3534-V6-S1    PIC       99V9.
  6549. 014000     03  HGT-AVG-3504-V6-S1                PIC       X(04).
  6550. 014100     03  HGT-AVG-RE-3504-V6-S1  REDEFINES  HGT-AVG-3504-V6-S1
  6551. 014200                                           PIC       999V9.
  6552. 014300     03  AVG-LDR-LGT-7313-V6-S1            PIC       X(03).
  6553. 014400     03  AVG-LDR-LGT-RE-7313-V6-S1  REDEFINES
  6554. 014500            AVG-LDR-LGT-7313-V6-S1         PIC       99V9.
  6555. 014600     03  FILLER                            PIC       X(35).
  6556. 014700 01  S-KEY2.
  6557. 014800     03  S-KEY1B.
  6558. 014900         05  REC-TYPE-3529-V7-S1           PIC       X(02).
  6559. 015000         05  FMT-NO-3576-V7-S1             PIC       X(01).
  6560. 015100         05  FMT-CD-3579-V7-S1             PIC       X(01).
  6561. 015200         05  ADM-UNIT-0003-V7-S1.
  6562. 015300             10  ADM-ST-0003-V7-S1         PIC       X(02).
  6563. 015400             10  ADM-DI-0003-V7-S1         PIC       X(02).
  6564. 015500             10  ADM-RA-0003-V7-S1         PIC       X(02).
  6565. 015600             10  ADM-PU-0003-V7-S1         PIC       X(02).
  6566. 015700         05  PLANT-CD1-2646-V7-S1          PIC       X(07).
  6567. 015800         05  FILLER                        PIC       X(05).
  6568. 015900     03  DATA-DT-6618-V7-S1                PIC       X(06).
  6569. 016000     03  ACT-CD-7350-V7-S1                 PIC       X(01).
  6570. 016100     03  LINE-NO-3578-V7-S1                PIC       X(04).
  6571. 016200     03  PLANT-CD-2646-V7-S1 OCCURS 9 TIMES PIC      X(07).
  6572. 016300     03  FILLER                            PIC       X(04).
  6573. 016400 01  S-KEY3.
  6574. 016500     03  S-KEY1C.
  6575. 016600         05  REC-TYPE-3529-VF-S1           PIC       X(02).
  6576. 016700         05  FMT-NO-3576-VF-S1             PIC       X(01).
  6577. 016800         05  FMT-CD-3579-VF-S1             PIC       X(01).
  6578. 016900         05  ADM-UNIT-0003-VF-S1.
  6579. 017000             10  ADM-ST-0003-VF-S1         PIC       X(02).
  6580. 017100             10  ADM-DI-0003-VF-S1         PIC       X(02).
  6581. 017200         05  ANML-GRZG-CD-3929-VF-S1       PIC       X(02).
  6582. 017300         05  FILLER                        PIC       X(14).
  6583. 017400     03  DATA-DT-6618-VF-S1                PIC       X(06).
  6584. 017500     03  ACT-CD-7350-VF-S1                 PIC       X(01).
  6585. 017600     03  LINE-NO-3578-VF-S1                PIC       X(04).
  6586. 017700     03  MON-FORG-RQMT-3551-VF-S1          PIC       X(04).
  6587. 017800     03  ANML-HGT-CLS-CD-3548-VF-S1        PIC       X(01).
  6588. 017900     03  ADM-RA-0003-VF-S1                 PIC       X(02).
  6589. 018000     03  ADM-PU-0003-VF-S1                 PIC       X(02).
  6590. 018100     03  FILLER                            PIC       X(58).
  6591. 018200 01  S-KEY4.
  6592. 018300     03  S-KEY1D.
  6593. 018400         05  REC-TYPE-3529-VP-S1           PIC       X(02).
  6594. 018500         05  FMT-NO-3576-VP-S1             PIC       X(01).
  6595. 018600         05  FMT-CD-3579-VP-S1             PIC       X(01).
  6596. 018700         05  ADM-UNIT-0003-VP-S1.
  6597. 018800             10  ADM-ST-0003-VP-S1         PIC       X(02).
  6598. 018900             10  ADM-DI-0003-VP-S1         PIC       X(02).
  6599. 019000             10  ADM-RA-0003-VP-S1         PIC       X(02).
  6600. 019100             10  ADM-PU-0003-VP-S1         PIC       X(02).
  6601. 019200         05  PLANT-CD-2646-VP-S1           PIC       X(07).
  6602. 019300         05  FILLER                        PIC       X(05).
  6603. 019400     03  DATA-DT-6618-VP-S1                PIC       X(06).
  6604. 019500     03  ACT-CD-7350-VP-S1                 PIC       X(01).
  6605. 019600     03  LINE-NO-3578-VP-S1                PIC       X(04).
  6606. 019700     03  PHNO-ADJ-FCTR-3545-RE-VP-S1       PIC       X(32).
  6607. 019800     03  PHNO-ADJ-FCTR-3545-VP-S1 REDEFINES
  6608. 019900           PHNO-ADJ-FCTR-3545-RE-VP-S1   OCCURS 8 TIMES PIC X(04).
  6609. 020000     03  PHNO-ADJ-FCTR-RE-3545-VP-S1 REDEFINES
  6610. 020100          PHNO-ADJ-FCTR-3545-RE-VP-S1  OCCURS 8 TIMES PIC  99V99.
  6611. 020200     03  FILLER                            PIC       X(35).
  6612. 020300 01  S-KEY5.
  6613. 020400     03  S-KEY1E.
  6614. 020500         05  REC-TYPE-3529-VU-S1           PIC       X(02).
  6615. 020600         05  FMT-NO-3576-VU-S1             PIC       X(01).
  6616. 020700         05  FMT-CD-3579-VU-S1             PIC       X(01).
  6617. 020800         05  ADM-UNIT-0003-VU-S1.
  6618. 020900             10  ADM-ST-0003-VU-S1         PIC       X(02).
  6619. 021000             10  ADM-DI-0003-VU-S1         PIC       X(02).
  6620. 021100             10  ADM-RA-0003-VU-S1         PIC       X(02).
  6621. 021200             10  ADM-PU-0003-VU-S1         PIC       X(02).
  6622. 021300         05  PLANT-CD-2646-VU-S1           PIC       X(07).
  6623. 021400         05  ANML-GRZG-CD-3929-VU-S1       PIC       X(02).
  6624. 021500         05  FILLER                        PIC       X(03).
  6625. 021600     03  DATA-DT-6618-VU-S1                PIC       X(06).
  6626. 021700     03  ACT-CD-7350-VU-S1                 PIC       X(01).
  6627. 021800     03  DUF-3917-VU-S1                    PIC       X(01).
  6628. 021900     03  LINE-NO-3578-VU-S1                PIC       X(04).
  6629. 022000     03  AUF-3928-VU-S1 OCCURS 5 TIMES     PIC       X(03).
  6630. 022100     03  PUF-3511-VU-S1 OCCURS 5 TIMES     PIC       X(02).
  6631. 022200     03  FILLER                            PIC        X(41).
  6632. 022300 WORKING-STORAGE SECTION.
  6633. 022400 77  INPUT1-CNT                  PIC       9(07)     VALUE 0.
  6634. 022500 77  PAGE-CNT                    PIC       9(05)     VALUE 0.
  6635. 022600 77  V6-CNT                      PIC       9(07)     VALUE 0.
  6636. 022700 77  VF-CNT                      PIC       9(07)     VALUE 0.
  6637. 022800 77  VP-CNT                      PIC       9(07)     VALUE 0.
  6638. 022900 77  VU-CNT                      PIC       9(07)     VALUE 0.
  6639. 023000 77  INPUT2-CNT                  PIC       9(07)     VALUE 0.
  6640. 023100 77  LINE-CNT                    PIC       9(02)     VALUE 66.
  6641. 023200 01  HLD-REC-TYPE                PIC       X(02)     VALUE SPACES.
  6642. 023300 01  MONTH-TABLE.
  6643. 023400     03  MO-TAB.
  6644. 023500         05  FILLER              PIC       X(03)     VALUE "JAN".
  6645. 023600         05  FILLER              PIC       X(03)     VALUE "FEB".
  6646. 023700         05  FILLER              PIC       X(03)     VALUE "MAR".
  6647. 023800         05  FILLER              PIC       X(03)     VALUE "APR".
  6648. 023900         05  FILLER              PIC       X(03)     VALUE "MAY".
  6649. 024000         05  FILLER              PIC       X(03)     VALUE "JUN".
  6650. 024100         05  FILLER              PIC       X(03)     VALUE "JUL".
  6651. 024200         05  FILLER              PIC       X(03)     VALUE "AUG".
  6652. 024300         05  FILLER              PIC       X(03)     VALUE "SEP".
  6653. 024400         05  FILLER              PIC       X(03)     VALUE "OCT".
  6654. 024500         05  FILLER              PIC       X(03)     VALUE "NOV".
  6655. 024600         05  FILLER              PIC       X(03)     VALUE "DEC".
  6656. 024700     03  MON REDEFINES MO-TAB    PIC       X(03) OCCURS 12 TIMES.
  6657. 024800 01  EOF-SWITCH                  PIC       9         VALUE ZERO.
  6658. 024900     88  EOF                               VALUE 1.
  6659. 025000 01  EOR-SWITCH                  PIC       9         VALUE ZERO.
  6660. 025100     88  EOR                               VALUE 1.
  6661. 025200 01  PARAMETER                   PIC       X(04).
  6662. 025300 01  HLD-DT.
  6663. 025400     03  HOLD-DT.
  6664. 025500         05  YR-DT               PIC       XX.
  6665. 025600         05  MO-DT               PIC       99.
  6666. 025700         05  DY-DT               PIC       XX.
  6667. 025800     03  INV-HLD.
  6668. 025900         05  INV-NM    PIC       X(20).
  6669. 026000         05  ST-DIST-CD.
  6670. 026100             07  ST-CD-HLD       PIC       X(02).
  6671. 026200             07  DI-CD-HLD       PIC       X(02).
  6672. 026300     03  EXPL-HLD.
  6673. 026400         05  DIST-NM-HLD         PIC       X(12).
  6674. 026500         05  RA-NM-HLD           PIC       X(13).
  6675. 026600         05  PU-NM-HLD           PIC       X(15).
  6676. 026700     03  FUNC-HLD.
  6677. 026800         05  ST-NM-HLD           PIC       X(10).
  6678. 026900         05  FILLER              PIC       X(14).
  6679. 027000     COPY DBSTATUS IN TPCOBOLIB.
  6680. 027100 01  HDR-1.
  6681. 027200     03  FILLER                  PIC       X(08)     VALUE
  6682. 027300         " DATE:  ".
  6683. 027400     03  HDR-MO                  PIC       X(03).
  6684. 027500     03  FILLER                  PIC       X(01)     VALUE SPACE.
  6685. 027600     03  HDR-DA                  PIC       X(02).
  6686. 027700     03  FILLER                  PIC       X(04)     VALUE ", 19".
  6687. 027800     03  HDR-YR                  PIC       X(02).
  6688. 027900     03  FILLER                  PIC       X(21)     VALUE SPACES.
  6689. 028000     03  FILLER                  PIC       X(47)     VALUE
  6690. 028100         "US DEPT OF INTERIOR - BUREAU OF LAND MANAGEMENT".
  6691. 028200     03  FILLER                  PIC       X(29)     VALUE SPACES.
  6692. 028300     03  FILLER                  PIC       X(07)     VALUE
  6693. 028400         "PAGE:  ".
  6694. 028500     03  HDR-PG                  PIC       ZZ,ZZ9.
  6695. 028600     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6696. 028700 01  HDR-2.
  6697. 028800     03  FILLER                  PIC       X(08)     VALUE
  6698. 028900         "STATE:  ".
  6699. 029000     03  HDR-ST-CD               PIC       X(02).
  6700. 029100     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6701. 029200     03  HDR-ST-NM               PIC       X(10).
  6702. 029300     03  FILLER                  PIC       X(30)     VALUE SPACES.
  6703. 029400     03  FILLER                  PIC       X(25)     VALUE
  6704. 029500         "ECOLOGICAL SITE INVENTORY".
  6705. 029600     03  FILLER                  PIC       X(35)     VALUE SPACES.
  6706. 029700     03  FILLER                  PIC       X(18)     VALUE
  6707. 029800         "PROGRAM:  ES115P  ".
  6708. 029900 01  HDR-3.
  6709. 030000     03  FILLER                  PIC       X(08)     VALUE
  6710. 030100         "   DI:  ".
  6711. 030200     03  HDR-DIST-CD             PIC       X(02).
  6712. 030300     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6713. 030400     03  HDR-DIST-NM             PIC       X(25).
  6714. 030500     03  FILLER                  PIC       X(79)     VALUE SPACES.
  6715. 030600     03  FILLER                  PIC       X(14)     VALUE
  6716. 030700         "PCN:  SV115P  ".
  6717. 030800 01  HDR-4.
  6718. 030900     03  FILLER                  PIC       X(08)     VALUE
  6719. 031000         "  INV:  ".
  6720. 031100     03  HDR-INV-CD              PIC       X(04).
  6721. 031200     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6722. 031300     03  HDR-INV-NM              PIC       X(25).
  6723. 031400     03  FILLER                  PIC       X(16)     VALUE SPACES.
  6724. 031500     03  HDR-REC-TYPE            PIC       X(02).
  6725. 031600     03  FILLER                  PIC       X(18)     VALUE
  6726. 031700         " VERIFICATION LIST".
  6727. 031800     03  FILLER                  PIC       X(57)     VALUE SPACES.
  6728. 031900 01  HDR-5-V6.
  6729. 032000     03  FILLER                  PIC       X(51)     VALUE
  6730. 032100         "(1-2)          (3)             (4)   (5)           ".
  6731. 032200     03  FILLER                  PIC       X(46)     VALUE
  6732. 032300         "(6)     (7)    (8)     (9)     (10)           ".
  6733. 032400     03  FILLER                  PIC       X(34)     VALUE
  6734. 032500         "(11-12)             (13)    (14)  ".
  6735. 032600 01  HDR-6-V6.
  6736. 032700     03  FILLER                  PIC       X(51)     VALUE
  6737. 032800         " REC    ADMINISTRATIVE UNIT   DATE   ACT    LINE   ".
  6738. 032900     03  FILLER                  PIC       X(39)     VALUE
  6739. 033000         "PLANT   PHEN-  GREEN   % DRY    DRY    ".
  6740. 033100     03  FILLER                  PIC       X(42)     VALUE
  6741. 033200         "BASAL -DIMENSIONS- CROWN    AVG    LEADER ".
  6742. 033300 01  HDR-7-V6.
  6743. 033400     03  FILLER                  PIC       X(45)     VALUE
  6744. 033500         "TYPE    ST   DI   RA   PU    YYMMDD   CD     ".
  6745. 033600     03  FILLER                  PIC       X(52)     VALUE
  6746. 033700         "NO    SYMBOL  OLOGY   WGT     WGT     WGT     MIN   ".
  6747. 033800     03  FILLER                  PIC       X(35)     VALUE
  6748. 033900         "MAX    MIN   MAX     HGT     LGTH  ".
  6749. 034000 01  HDR-8-V6.
  6750. 034100     03  FILLER                  PIC       X(51)     VALUE
  6751. 034200         " 1-4    5-6  7-8 9-10 11-12  13-18    19    20-23  ".
  6752. 034300     03  FILLER                  PIC       X(52)     VALUE
  6753. 034400         "24-30     31    32-35   36-38   39-42  43-46 47-50  ".
  6754. 034500     03  FILLER                  PIC       X(29)     VALUE
  6755. 034600         "51-53 54-56   57-60    61-63 ".
  6756. 034700 01  HDR-9-V6.
  6757. 034800     03  FILLER                  PIC       X(44)     VALUE
  6758. 034900         "XXXX    XX   XX   XX   XX    XXXXXX   X     ".
  6759. 035000     03  FILLER                  PIC       X(46)     VALUE
  6760. 035100         "XXXX   XXXXXXX   X     XXXX    XXX     XXXX   ".
  6761. 035200     03  FILLER                  PIC       X(42)     VALUE
  6762. 035300         "99.99 99.99  99.9  99.9    999.9    99.9  ".
  6763. 035400 01  HDR-10-DET-V6.
  6764. 035500     03  REC-TYPE-3529-V6-P1     PIC       X(02).
  6765. 035600     03  FMT-NO-3576-V6-P1       PIC       X(01).
  6766. 035700     03  FMT-CD-3579-V6-P1       PIC       X(01).
  6767. 035800     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6768. 035900     03  ADM-ST-0003-V6-P1       PIC       X(02).
  6769. 036000     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6770. 036100     03  ADM-DI-0003-V6-P1       PIC       X(02).
  6771. 036200     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6772. 036300     03  ADM-RA-0003-V6-P1       PIC       X(02).
  6773. 036400     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6774. 036500     03  ADM-PU-0003-V6-P1       PIC       X(02).
  6775. 036600     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6776. 036700     03  DATA-DT-6618-V6-P1      PIC       X(06).
  6777. 036800     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6778. 036900     03  ACT-CD-7350-V6-P1       PIC       X(01).
  6779. 037000     03  FILLER                  PIC       X(05)     VALUE SPACES.
  6780. 037100     03  LINE-NO-3578-V6-P1      PIC       X(04).
  6781. 037200     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6782. 037300     03  PLANT-CD-2646-V6-P1     PIC       X(07).
  6783. 037400     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6784. 037500     03  PHNO-STG-CD-3712-V6-P1  PIC       X(01).
  6785. 037600     03  FILLER                  PIC       X(05)     VALUE SPACES.
  6786. 037700     03  GRAMS-GRN-WGT-3941-V6-P1  PIC     X(04).
  6787. 037800     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6788. 037900     03  ADW-PCT-3546-V6-P1      PIC       X(03).
  6789. 038000     03  FILLER                  PIC       X(05)     VALUE SPACES.
  6790. 038100     03  GRAMS-DRY-WGT-3942-V6-P1  PIC     X(04).
  6791. 038200     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6792. 038300     03  BA-DIMS-MIN-3533-V6-P1  PIC       X(05).
  6793. 038400     03  BA-DIMS-MIN-RE-3533-V6-P1 REDEFINES
  6794. 038500            BA-DIMS-MIN-3533-V6-P1  PIC    99.99.
  6795. 038600     03  FILLER                  PIC       X(01)     VALUE SPACE.
  6796. 038700     03  BA-DIMS-MAX-3533-V6-P1  PIC       X(05).
  6797. 038800     03  BA-DIMS-MAX-RE-3533-V6-P1 REDEFINES
  6798. 038900            BA-DIMS-MAX-3533-V6-P1  PIC    99.99.
  6799. 039000     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6800. 039100     03  CRN-DIMS-MIN-3534-V6-P1  PIC      X(04).
  6801. 039200     03  CRN-DIMS-MIN-RE-3534-V6-P1 REDEFINES
  6802. 039300            CRN-DIMS-MIN-3534-V6-P1  PIC    99.9.
  6803. 039400     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6804. 039500     03  CRN-DIMS-MAX-3534-V6-P1 PIC       X(04).
  6805. 039600     03  CRN-DIMS-MAX-RE-3534-V6-P1 REDEFINES
  6806. 039700            CRN-DIMS-MAX-3534-V6-P1  PIC   99.9.
  6807. 039800     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6808. 039900     03  HGT-AVG-3504-V6-P1                PIC       X(05).
  6809. 040000     03  HGT-AVG-RE-3504-V6-P1 REDEFINES
  6810. 040100            HGT-AVG-3504-V6-P1  PIC    999.9.
  6811. 040200     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6812. 040300     03  AVG-LDR-LGT-7313-V6-P1  PIC       X(04).
  6813. 040400     03  AVG-LDR-LGT-RE-7313-V6-P1 REDEFINES
  6814. 040500            AVG-LDR-LGT-7313-V6-P1  PIC   99.9.
  6815. 040600     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6816. 040700 01  HDR-5-V7.
  6817. 040800     03  FILLER                  PIC       X(52)     VALUE
  6818. 040900         "(1-2)          (3)             (4)   (5)            ".
  6819. 041000     03  FILLER                  PIC       X(51)     VALUE
  6820. 041100         "(6)      (7)       PHENOLOGICAL EQUIVALENT SPECIES ".
  6821. 041200     03  FILLER                  PIC       X(29)     VALUE
  6822. 041300         "(UNSAMPLED)          (7)     ".
  6823. 041400 01  HDR-6-V7.
  6824. 041500     03  FILLER                  PIC       X(51)     VALUE
  6825. 041600         " REC    ADMINISTRATIVE UNIT   DATE   ACT    LINE   ".
  6826. 041700     03  FILLER                  PIC       X(54)     VALUE
  6827. 041800         "PLANT    PLANT    PLANT    PLANT    PLANT    PLANT    ".
  6828. 041900     03  FILLER                  PIC       X(27)     VALUE
  6829. 042000         "PLANT    PLANT    PLANT    ".
  6830. 042100 01  HDR-7-V7.
  6831. 042200     03  FILLER                  PIC       X(51)     VALUE
  6832. 042300         "TYPE    ST   DI   RA   PU    YYMMDD   CD     NO    ".
  6833. 042400     03  FILLER                  PIC       X(54)     VALUE
  6834. 042500         "SYMBOL   SYMBOL   SYMBOL   SYMBOL   SYMBOL   SYMBOL   ".
  6835. 042600     03  FILLER                  PIC       X(27)     VALUE
  6836. 042700         "SYMBOL   SYMBOL   SYMBOL   ".
  6837. 042800 01  HDR-8-V7.
  6838. 042900     03  FILLER                  PIC       X(51)     VALUE
  6839. 043000         " 1-4    5-6  7-8 9-10 11-12  13-18    19    20-23  ".
  6840. 043100     03  FILLER                  PIC       X(54)     VALUE
  6841. 043200         "24-30    31-37    38-44    45-51    52-58    59-65    ".
  6842. 043300     03  FILLER                  PIC       X(27)     VALUE
  6843. 043400         "66-72    73-79    80-86    ".
  6844. 043500 01  HDR-9-V7.
  6845. 043600     03  FILLER                  PIC       X(44)     VALUE
  6846. 043700         "XXXX    XX   XX   XX   XX    XXXXXX   X     ".
  6847. 043800     03  FILLER                  PIC       X(51)     VALUE
  6848. 043900         "XXXX  XXXXXXX  XXXXXXX  XXXXXXX  XXXXXXX  XXXXXXX  ".
  6849. 044000     03  FILLER                  PIC       X(37)     VALUE
  6850. 044100         "XXXXXXX  XXXXXXX  XXXXXXX  XXXXXXX   ".
  6851. 044200 01  HDR-10-DET-V7.
  6852. 044300     03  REC-TYPE-3529-V7-P1     PIC       X(02).
  6853. 044400     03  FMT-NO-3576-V7-P1       PIC       X(01).
  6854. 044500     03  FMT-CD-3579-V7-P1       PIC       X(01).
  6855. 044600     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6856. 044700     03  ADM-ST-0003-V7-P1       PIC       X(02).
  6857. 044800     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6858. 044900     03  ADM-DI-0003-V7-P1       PIC       X(02).
  6859. 045000     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6860. 045100     03  ADM-RA-0003-V7-P1       PIC       X(02).
  6861. 045200     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6862. 045300     03  ADM-PU-0003-V7-P1       PIC       X(02).
  6863. 045400     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6864. 045500     03  DATA-DT-6618-V7-P1      PIC       X(06).
  6865. 045600     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6866. 045700     03  ACT-CD-7350-V7-P1       PIC       X(01).
  6867. 045800     03  FILLER                  PIC       X(05)     VALUE SPACES.
  6868. 045900     03  LINE-NO-3578-V7-P1      PIC       X(04).
  6869. 046000     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6870. 046100     03  PLANT-CD1-2646-V7-P1    PIC       X(07).
  6871. 046200     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6872. 046300     03  PLANT-CD2-2646-V7-P1    PIC       X(07).
  6873. 046400     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6874. 046500     03  PLANT-CD3-2646-V7-P1    PIC       X(07).
  6875. 046600     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6876. 046700     03  PLANT-CD4-2646-V7-P1    PIC       X(07).
  6877. 046800     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6878. 046900     03  PLANT-CD5-2646-V7-P1    PIC       X(07).
  6879. 047000     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6880. 047100     03  PLANT-CD6-2646-V7-P1    PIC       X(07).
  6881. 047200     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6882. 047300     03  PLANT-CD7-2646-V7-P1    PIC       X(07).
  6883. 047400     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6884. 047500     03  PLANT-CD8-2646-V7-P1    PIC       X(07).
  6885. 047600     03  FILLER                  PIC       X(02)     VALUE SPACES.
  6886. 047700     03  PLANT-CD9-2646-V7-P1    PIC       X(07).
  6887. 047800     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6888. 047900 01  HDR-5-VF.
  6889. 048000     03  FILLER                  PIC       X(40)     VALUE
  6890. 048100         "(1-2          (3)             (4)   (5)".
  6891. 048200     03  FILLER                  PIC       X(92)     VALUE SPACES.
  6892. 048300 01  HDR-6-VF.
  6893. 048400     03  FILLER                  PIC       X(49)     VALUE
  6894. 048500         " REC    ADMINISTRATIVE UNIT   DATE   ACT    LINE".
  6895. 048600     03  FILLER                  PIC       X(12)     VALUE SPACES.
  6896. 048700     03  FILLER                  PIC       X(51)     VALUE
  6897. 048800         "ANIMAL  SPECIES            MO FOR     HEIGHT CLASS ".
  6898. 048900     03  FILLER                  PIC       X(21)     VALUE
  6899. 049000         "AVAILABLE TO ANIMAL  ".
  6900. 049100 01  HDR-7-VF.
  6901. 049200     03  FILLER                  PIC       X(47)     VALUE
  6902. 049300         "TYPE      ST       DI        YYMMDD   CD     NO".
  6903. 049400     03  FILLER                  PIC       X(45)     VALUE
  6904. 049500         "               NAME               CD     REQ".
  6905. 049600     03  FILLER                  PIC       X(40)     VALUE
  6906. 049700         "      0'-3'   3'-4.5'  4.5'-7'  7' PLUS ".
  6907. 049800 01  HDR-8-VF.
  6908. 049900     03  FILLER                  PIC       X(49)     VALUE
  6909. 050000         " 1-4      5-6      7-8       13-18    19    20-23".
  6910. 050100     03  FILLER                  PIC       X(32)     VALUE SPACES.
  6911. 050200     03  FILLER                  PIC       X(51)     VALUE
  6912. 050300         "24-25 26-29       X        X         X        X    ".
  6913. 050400 01  HDR-9-VF.
  6914. 050500     03  FILLER                  PIC       X(53)     VALUE
  6915. 050600         "XXXX      XX       XX        XXXXXX   X     XXXX     ".
  6916. 050700     03  FILLER                  PIC       X(46)     VALUE
  6917. 050800         "XXXXXXXXXXXXXXXXXXXXXXXXX    XX    XXXX       ".
  6918. 050900     03  FILLER                  PIC       X(33)     VALUE
  6919. 051000         "1        2         3        4    ".
  6920. 051100 01  HDR-10-DET-VF.
  6921. 051200     03  REC-TYPE-3529-VF-P1     PIC       X(02).
  6922. 051300     03  FMT-NO-3576-VF-P1       PIC       X(01).
  6923. 051400     03  FMT-CD-3579-VF-P1       PIC       X(01).
  6924. 051500     03  FILLER                  PIC       X(06)     VALUE SPACES.
  6925. 051600     03  ADM-ST-0003-VF-P1       PIC       X(02).
  6926. 051700     03  FILLER                  PIC       X(07)     VALUE SPACES.
  6927. 051800     03  ADM-DI-0003-VF-P1       PIC       X(02).
  6928. 051900     03  FILLER                  PIC       X(08)     VALUE SPACES.
  6929. 052000     03  DATA-DT-6618-VF-P1      PIC       X(06).
  6930. 052100     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6931. 052200     03  ACT-CD-7350-VF-P1       PIC       X(01).
  6932. 052300     03  FILLER                  PIC       X(05)     VALUE SPACES.
  6933. 052400     03  LINE-NO-3578-VF-P1      PIC       X(04).
  6934. 052500     03  FILLER                  PIC       X(05)     VALUE SPACES.
  6935. 052600     03  ANML-GRZG-NAME-VF-P1    PIC       X(25).
  6936. 052700     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6937. 052800     03  ANML-GRZG-CD-3929-VF-P1 PIC       X(02).
  6938. 052900     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6939. 053000     03  MON-FORG-RQMT-3551-VF-P1 PIC      X(04).
  6940. 053100     03  FILLER                  PIC       X(07)     VALUE SPACES.
  6941. 053200     03  ANML-HGT-0-3-3548-VF-P1 PIC       X(01).
  6942. 053300     03  FILLER                  PIC       X(08)     VALUE SPACES.
  6943. 053400     03  ANML-HGT-3-4-3548-VF-P1 PIC       X(01).
  6944. 053500     03  FILLER                  PIC       X(09)     VALUE SPACES.
  6945. 053600     03  ANML-HGT-4-7-3548-VF-P1 PIC       X(01).
  6946. 053700     03  FILLER                  PIC       X(08)     VALUE SPACES.
  6947. 053800     03  ANML-HGT-7-OVR-3548-VF-P1  PIC     X(01).
  6948. 053900     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6949. 054000 01  HDR-5-VP.
  6950. 054100     03  FILLER                  PIC       X(40)     VALUE
  6951. 054200         "(1-2)          (3)             (4)   (5)".
  6952. 054300     03  FILLER                  PIC       X(49)     VALUE
  6953. 054400         "               (6)     (7)    PERCENT OF MAXIMUM ".
  6954. 054500     03  FILLER                  PIC       X(43)     VALUE
  6955. 054600         "PRODUCTION BY PHENOLOGY STATE         (7)  ".
  6956. 054700 01  HDR-6-VP.
  6957. 054800     03  FILLER                  PIC       X(54)     VALUE
  6958. 054900         " REC    ADMINISTRATIVE UNIT   DATE   ACT    LINE      ".
  6959. 055000     03  FILLER                  PIC       X(49)     VALUE
  6960. 055100         "PLANT     BEG      VEG     BOOT     PEAK     SEED".
  6961. 055200     03  FILLER                  PIC       X(25)     VALUE SPACES.
  6962. 055300     03  FILLER                  PIC       X(4)      VALUE
  6963. 055400         "RE- ".
  6964. 055500 01  HDR-7-VP.
  6965. 055600     03  FILLER                  PIC       X(47)     VALUE
  6966. 055700         "TYPE    ST   DI   RA   PU    YYMMDD   CD     NO".
  6967. 055800     03  FILLER                  PIC       X(48)     VALUE
  6968. 055900         "      SYMBOL    GROWTH   STAGE    STAGE    FLURG".
  6969. 056000     03  FILLER                  PIC       X(37)     VALUE
  6970. 056100         "    RIPE     MAT      DORM     GROWTH".
  6971. 056200 01  HDR-8-VP.
  6972. 056300     03  FILLER                  PIC       X(53)     VALUE
  6973. 056400         "1-4    5-6  7-8 9-10 11-12  13-18    19    20-23    ".
  6974. 056500     03  FILLER                  PIC       X(51)     VALUE
  6975. 056600         "24-30     31-34    35-38    39-42    43-46    47-50".
  6976. 056700     03  FILLER                  PIC       X(28)     VALUE
  6977. 056800         "    51-54    55-58    59-62 ".
  6978. 056900 01  HDR-9-VP.
  6979. 057000     03  FILLER                  PIC       X(52)     VALUE
  6980. 057100         "XXXX    XX   XX   XX   XX    XXXXXX   X     XXXX    ".
  6981. 057200     03  FILLER                  PIC       X(52)     VALUE
  6982. 057300         "XXXXXXX    99.99    99.99    99.99    99.99    99.99".
  6983. 057400     03  FILLER                  PIC       X(28)     VALUE
  6984. 057500         "    99.99    99.99    99.99 ".
  6985. 057600 01  HDR-10-DET-VP.
  6986. 057700     03  REC-TYPE-3529-VP-P1     PIC       X(02).
  6987. 057800     03  FMT-NO-3576-VP-P1       PIC       X(01).
  6988. 057900     03  FMT-CD-3579-VP-P1       PIC       X(01).
  6989. 058000     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6990. 058100     03  ADM-ST-0003-VP-P1       PIC       X(02).
  6991. 058200     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6992. 058300     03  ADM-DI-0003-VP-P1       PIC       X(02).
  6993. 058400     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6994. 058500     03  ADM-RA-0003-VP-P1       PIC       X(02).
  6995. 058600     03  FILLER                  PIC       X(03)     VALUE SPACES.
  6996. 058700     03  ADM-PU-0003-VP-P1       PIC       X(02).
  6997. 058800     03  FILLER                  PIC       X(04)     VALUE SPACES.
  6998. 058900     03  DATA-DT-6618-VP-P1      PIC       X(06).
  6999. 059000     03  FILLER                  PIC       X(03)     VALUE SPACES.
  7000. 059100     03  ACT-CD-7350-VP-P1       PIC       X(01).
  7001. 059200     03  FILLER                  PIC       X(05)     VALUE SPACES.
  7002. 059300     03  LINE-NO-3578-VP-P1      PIC       X(04).
  7003. 059400     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7004. 059500     03  PLANT-CD-2646-VP-P1     PIC       X(07).
  7005. 059600     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7006. 059700     03  PHNO-ADJ-FCTR1-3545-VP-P1  PIC  99.99.
  7007. 059800     03  PHNO-ADJ-FCTR1-RE-3545-VP-P1 REDEFINES
  7008. 059900         PHNO-ADJ-FCTR1-3545-VP-P1           PIC      X(05).
  7009. 060000     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7010. 060100     03  PHNO-ADJ-FCTR2-3545-VP-P1  PIC 99.99.
  7011. 060200     03  PHNO-ADJ-FCTR2-RE-3545-VP-P1  REDEFINES
  7012. 060300             PHNO-ADJ-FCTR2-3545-VP-P1     PIC      X(05).
  7013. 060400     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7014. 060500     03  PHNO-ADJ-FCTR3-3545-VP-P1  PIC  99.99.
  7015. 060600     03  PHNO-ADJ-FCTR3-RE-3545-VP-P1 REDEFINES
  7016. 060700             PHNO-ADJ-FCTR3-3545-VP-P1     PIC       X(05).
  7017. 060800     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7018. 060900     03  PHNO-ADJ-FCTR4-3545-VP-P1  PIC  99.99.
  7019. 061000     03  PHNO-ADJ-FCTR4-RE-3545-VP-P1 REDEFINES
  7020. 061100          PHNO-ADJ-FCTR4-3545-VP-P1     PIC       X(05).
  7021. 061200     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7022. 061300     03  PHNO-ADJ-FCTR5-3545-VP-P1  PIC  99.99.
  7023. 061400     03  PHNO-ADJ-FCTR5-RE-3545-VP-P1 REDEFINES
  7024. 061500          PHNO-ADJ-FCTR5-3545-VP-P1      PIC      X(05).
  7025. 061600     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7026. 061700     03  PHNO-ADJ-FCTR6-3545-VP-P1  PIC  99.99.
  7027. 061800     03  PHNO-ADJ-FCTR6-RE-3545-VP-P1 REDEFINES
  7028. 061900          PHNO-ADJ-FCTR6-3545-VP-P1      PIC     X(05).
  7029. 062000     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7030. 062100     03  PHNO-ADJ-FCTR7-3545-VP-P1  PIC  99.99.
  7031. 062200     03  PHNO-ADJ-FCTR7-RE-3545-VP-P1 REDEFINES
  7032. 062300          PHNO-ADJ-FCTR7-3545-VP-P1     PIC      X(05).
  7033. 062400     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7034. 062500     03  PHNO-ADJ-FCTR8-3545-VP-P1  PIC  99.99.
  7035. 062600     03  PHNO-ADJ-FCTR8-RE-3545-VP-P1 REDEFINES
  7036. 062700          PHNO-ADJ-FCTR8-3545-VP-P1    PIC     X(05).
  7037. 062800     03  FILLER                  PIC       X(01)     VALUE SPACES.
  7038. 062900 01  HDR-5-VU.
  7039. 063000      03  FILLER                  PIC       X(5)      VALUE
  7040. 063100          "(1-2)".
  7041. 063200      03  FILLER                  PIC       X(26)    VALUE SPACES.
  7042. 063300      03  FILLER                  PIC       X(18)     VALUE
  7043. 063400          "(4)    (5)  (9-10)".
  7044. 063500      03  FILLER                  PIC       X(12)    VALUE SPACES.
  7045. 063600      03  FILLER                  PIC       X(39)     VALUE
  7046. 063700          "(6)   (7) ALLOWABLE USE FACTOR (7)  (8)".
  7047. 063800      03  FILLER                  PIC       X(5)     VALUE SPACES.
  7048. 063900      03  FILLER                  PIC       X(27)     VALUE
  7049. 064000          "PROPER USE FACTOR  OR      ".
  7050. 064100 01  HDR-6-VU.
  7051. 064200     03  FILLER                  PIC       X(51)     VALUE
  7052. 064300         " REC    ADMINISTRATIVE UNIT   DATE    ACT   P OR   ".
  7053. 064400     03  FILLER                  PIC       X(54)     VALUE
  7054. 064500         "LINE     PLANT   (PERCENT OF PLANT UTILIZED) ANIM     ".
  7055. 064600      03  FILLER                  PIC       X(27)     VALUE
  7056. 064700          "DIETARY PREFERENCE VALUE   ".
  7057. 064800 01  HDR-7-VU.
  7058. 064900     03  FILLER                  PIC       X(52)     VALUE
  7059. 065000         "TYPE    ST   DI   RA   PU    YYMMDD    CD    D      ".
  7060. 065100     03  FILLER                  PIC       X(51)     VALUE
  7061. 065200         "NO     SYMBOL  SPRING SUM   FALL  WINT   YR  SP    ".
  7062. 065300     03  FILLER                  PIC       X(29)     VALUE
  7063. 065400         "SPRING SUM   FALL  WINT   YR ".
  7064. 065500 01  HDR-8-VU.
  7065. 065600     03  FILLER                  PIC       X(51)     VALUE
  7066. 065700         " 1-4    5-6  7-8 9-10 11-12  13-18     19    20    ".
  7067. 065800     03  FILLER                  PIC       X(52)     VALUE
  7068. 065900         "21-24   25-31   32-34 35-37 38-40 41-43 44-46 47-48 ".
  7069. 066000     03  FILLER                  PIC       X(30)     VALUE
  7070. 066100         " 49-50 51-52 53-54 55-56 57-58".
  7071. 066200 01  HDR-9-VU.
  7072. 066300     03  FILLER                  PIC       X(51)     VALUE
  7073. 066400         "XXXX    XX   XX   XX   XX    XXXXXX    X     X     ".
  7074. 066500     03  FILLER                  PIC       X(47)     VALUE
  7075. 066600         "XXXX   XXXXXXX   XXX   XXX   XXX   XXX   XXX   ".
  7076. 066700     03   FILLER                 PIC       X(34)     VALUE
  7077. 066800         "XX    XX    XX    XX    XX    XX  ".
  7078. 066900 01  HDR-10-DET-VU.
  7079. 067000     03  REC-TYPE-3529-VU-P1     PIC       X(02).
  7080. 067100     03  FMT-NO-3576-VU-P1       PIC       X(01).
  7081. 067200     03  FMT-CD-3579-VU-P1       PIC       X(01).
  7082. 067300     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7083. 067400     03  ADM-ST-0003-VU-P1       PIC       X(02).
  7084. 067500     03  FILLER                  PIC       X(03)     VALUE SPACES.
  7085. 067600     03  ADM-DI-0003-VU-P1       PIC       X(02).
  7086. 067700     03  FILLER                  PIC       X(03)     VALUE SPACES.
  7087. 067800     03  ADM-RA-0003-VU-P1       PIC       X(02).
  7088. 067900     03  FILLER                  PIC       X(03)     VALUE SPACES.
  7089. 068000     03  ADM-PU-0003-VU-P1       PIC       X(02).
  7090. 068100     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7091. 068200     03  DATA-DT-6618-VU-P1      PIC       X(06).
  7092. 068300     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7093. 068400     03  ACT-CD-7350-VU-P1       PIC       X(01).
  7094. 068500     03  FILLER                  PIC       X(05)     VALUE SPACES.
  7095. 068600     03  DUF-3917-VU-P1          PIC       X(01).
  7096. 068700     03  FILLER                  PIC       X(05)     VALUE SPACES.
  7097. 068800     03  LINE-NO-3578-VU-P1      PIC       X(04).
  7098. 068900     03  FILLER                  PIC       X(03)     VALUE SPACES.
  7099. 069000     03  PLANT-CD-2646-VU-P1     PIC       X(07).
  7100. 069100     03  FILLER                  PIC       X(03)     VALUE SPACES.
  7101. 069200     03  AUF1-3928-VU-P1         PIC       X(03).
  7102. 069300     03  FILLER                  PIC       X(03)     VALUE SPACES.
  7103. 069400     03  AUF2-3928-VU-P1         PIC       X(03).
  7104. 069500     03  FILLER                  PIC       X(03)     VALUE SPACES.
  7105. 069600     03  AUF3-3928-VU-P1         PIC       X(03).
  7106. 069700     03  FILLER                  PIC       X(03)     VALUE SPACES.
  7107. 069800     03  AUF4-3928-VU-P1         PIC       X(03).
  7108. 069900     03  FILLER                  PIC       X(03)     VALUE SPACES.
  7109. 070000     03  AUF5-3928-VU-P1         PIC       X(03).
  7110. 070100     03  FILLER                  PIC       X(03)     VALUE SPACES.
  7111. 070200     03  ANML-GRZG-CD-3929-VU-P1 PIC       X(02).
  7112. 070300     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7113. 070400     03  PUF1-3511-VU-P1         PIC       X(02).
  7114. 070500     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7115. 070600     03  PUF2-3511-VU-P1         PIC       X(02).
  7116. 070700     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7117. 070800     03  PUF3-3511-VU-P1         PIC       X(02).
  7118. 070900     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7119. 071000     03  PUF4-3511-VU-P1         PIC       X(02).
  7120. 071100     03  FILLER                  PIC       X(04)     VALUE SPACES.
  7121. 071200     03  PUF5-3511-VU-P1         PIC       X(02).
  7122. 071300     03  FILLER                  PIC       X(02)     VALUE SPACES.
  7123. 071400 PROCEDURE DIVISION.
  7124. 071500 START-SORT SECTION.
  7125. 071600 100-SORT.
  7126. 071700             SORT SORT-FILE ON ASCENDING S-KEY1A
  7127. 071800     INPUT PROCEDURE PRE-SORT
  7128. 071900     OUTPUT PROCEDURE POST-SORT.
  7129. 072000 200-END-SECTION.
  7130. 072100     FINISH DIC-DE.
  7131. 072200     DISPLAY "V6-CNT"  V6-CNT.
  7132. 072300     DISPLAY "V7-CNT"  INPUT2-CNT.
  7133. 072400     DISPLAY "VF-CNT"  VF-CNT.
  7134. 072500     DISPLAY "VP-CNT"  VP-CNT.
  7135. 072600     DISPLAY "VU-CNT"  VU-CNT.
  7136. 072700     CLOSE PRINT-FILE.
  7137. 072800     STOP RUN.
  7138. 072900 PRE-SORT SECTION.
  7139. 073000 300-HSKPNG.
  7140. 073100     OPEN INPUT INPUT-FILE1.
  7141. 073200     MOVE SPACES TO S-KEY1  S-KEY2  S-KEY3  S-KEY4  S-KEY5.
  7142. 073300 400-MAIN.
  7143. 073400     PERFORM  500-RD-FILE1 THRU 600-EXIT-RD-FL1 UNTIL EOF.
  7144. 073500     MOVE 0 TO EOF-SWITCH.
  7145. 073600     CLOSE INPUT-FILE1.
  7146. 073700     OPEN INPUT INPUT-FILE2.
  7147. 073800     PERFORM 2000-RD-FILE2 THRU 3000-EXIT-RD-FL2 UNTIL EOF.
  7148. 073900     CLOSE INPUT-FILE2.
  7149. 074000     GO TO 3000-EXIT-RD-FL2.
  7150. 074100 500-RD-FILE1.
  7151. 074200     READ INPUT-FILE1  AT END MOVE 1 TO EOF-SWITCH.
  7152. 074300     IF  (EOF-SWITCH = 1) GO TO 600-EXIT-RD-FL1.
  7153. 074400     ADD 1 TO INPUT1-CNT.
  7154. 074500     IF  REC-TYPE-3529-V6-I1 = "V6"
  7155. 074600         PERFORM 700-MV-V6-TO-SRT THRU 750-EXIT-V6
  7156. 074700         GO  TO 600-EXIT-RD-FL1.
  7157. 074800     IF  REC-TYPE-3529-VF-I1 = "VF"
  7158. 074900         PERFORM 800-MV-VF-TO-SRT THRU 850-EXIT-VF
  7159. 075000         GO  TO 600-EXIT-RD-FL1.
  7160. 075100     IF  REC-TYPE-3529-VP-I1 = "VP"
  7161. 075200         PERFORM 900-MV-VP-TO-SRT THRU 950-EXIT-VP
  7162. 075300         GO  TO 600-EXIT-RD-FL1.
  7163. 075400     IF  REC-TYPE-3529-VU-I1 = "VU"
  7164. 075500         PERFORM 1000-MV-VU-TO-SRT THRU 1050-EXIT-VU
  7165. 075600         GO  TO 600-EXIT-RD-FL1.
  7166. 075700 600-EXIT-RD-FL1.
  7167. 075800     EXIT.
  7168. 075900 700-MV-V6-TO-SRT.
  7169. 076000     ADD 1 TO V6-CNT.
  7170. 076100     MOVE REC-TYPE-3529-V6-I1 TO REC-TYPE-3529-V6-S1.
  7171. 076200     MOVE FMT-NO-3576-V6-I1 TO FMT-NO-3576-V6-S1.
  7172. 076300     MOVE FMT-CD-3579-V6-I1 TO FMT-CD-3579-V6-S1.
  7173. 076400     MOVE ADM-UNIT-0003-V6-I1 TO ADM-UNIT-0003-V6-S1.
  7174. 076500     MOVE DATA-DT-6618-V6-I1 TO DATA-DT-6618-V6-S1.
  7175. 076600     MOVE ACT-CD-7350-V6-I1 TO ACT-CD-7350-V6-S1.
  7176. 076700     MOVE LINE-NO-3578-V6-I1 TO LINE-NO-3578-V6-S1.
  7177. 076800     MOVE PLANT-CD-2646-V6-I1 TO PLANT-CD-2646-V6-S1.
  7178. 076900     MOVE PHNO-STG-CD-3712-V6-I1 TO PHNO-STG-CD-3712-V6-S1.
  7179. 077000     MOVE GRAMS-GRN-WGT-3941-V6-I1 TO GRAMS-GRN-WGT-3941-V6-S1.
  7180. 077100     MOVE ADW-PCT-3546-V6-I1 TO ADW-PCT-3546-V6-S1.
  7181. 077200     MOVE GRAMS-DRY-WGT-3942-V6-I1 TO GRAMS-DRY-WGT-3942-V6-S1.
  7182. 077300     MOVE BASAL-DIMS-3533-V6-I1 TO BA-DIMS-3533-V6-S1.
  7183. 077400     MOVE CROWN-DIMS-3534-V6-I1 TO CRN-DIMS-3534-V6-S1.
  7184. 077500     MOVE HGT-AVG-3504-V6-I1 TO HGT-AVG-3504-V6-S1.
  7185. 077600     MOVE AVG-LDR-LGT-7313-V6-I1 TO AVG-LDR-LGT-7313-V6-S1.
  7186. 077700     RELEASE  S-KEY1.
  7187. 077800 750-EXIT-V6.
  7188. 077900     EXIT.
  7189. 078000 800-MV-VF-TO-SRT.
  7190. 078100     ADD 1 TO VF-CNT.
  7191. 078200     MOVE REC-TYPE-3529-VF-I1 TO REC-TYPE-3529-VF-S1.
  7192. 078300     MOVE FMT-NO-3576-VF-I1 TO FMT-NO-3576-VF-S1.
  7193. 078400     MOVE FMT-CD-3579-VF-I1 TO FMT-CD-3579-VF-S1.
  7194. 078500     MOVE ADM-ST-0003-VF-I1 TO ADM-ST-0003-VF-S1.
  7195. 078600     MOVE ADM-DI-0003-VF-I1 TO ADM-DI-0003-VF-S1.
  7196. 078700     MOVE DATA-DT-6618-VF-I1 TO DATA-DT-6618-VF-S1.
  7197. 078800     MOVE ACT-CD-7350-VF-I1 TO ACT-CD-7350-VF-S1.
  7198. 078900     MOVE LINE-NO-3578-VF-I1 TO LINE-NO-3578-VF-S1.
  7199. 079000     MOVE ANML-GRZG-CD-3929-VF-I1 TO ANML-GRZG-CD-3929-VF-S1.
  7200. 079100     MOVE MON-FORG-RQMT-3551-VF-I1 TO MON-FORG-RQMT-3551-VF-S1.
  7201. 079200     MOVE ANML-HGT-CLS-CD-3548-VF-I1 TO ANML-HGT-CLS-CD-3548-VF-S1
  7202. 079300     RELEASE  S-KEY3.
  7203. 079400 850-EXIT-VF.
  7204. 079500     EXIT.
  7205. 079600 900-MV-VP-TO-SRT.
  7206. 079700     ADD 1 TO VP-CNT.
  7207. 079800     MOVE REC-TYPE-3529-VP-I1 TO REC-TYPE-3529-VP-S1.
  7208. 079900     MOVE FMT-NO-3576-VP-I1 TO FMT-NO-3576-VP-S1.
  7209. 080000     MOVE FMT-CD-3579-VP-I1 TO FMT-CD-3579-VP-S1.
  7210. 080100     MOVE ADM-UNIT-0003-VP-I1 TO ADM-UNIT-0003-VP-S1.
  7211. 080200     MOVE DATA-DT-6618-VP-I1 TO DATA-DT-6618-VP-S1.
  7212. 080300     MOVE ACT-CD-7350-VP-I1 TO ACT-CD-7350-VP-S1.
  7213. 080400     MOVE LINE-NO-3578-VP-I1 TO LINE-NO-3578-VP-S1.
  7214. 080500     MOVE PLANT-CD-2646-VP-I1 TO PLANT-CD-2646-VP-S1.
  7215. 080600     MOVE PHNO-ADJ-FCTR-3545-VP-I1 (1) TO
  7216. 080700           PHNO-ADJ-FCTR-3545-VP-S1 (1).
  7217. 080800     MOVE PHNO-ADJ-FCTR-3545-VP-I1 (2) TO
  7218. 080900           PHNO-ADJ-FCTR-3545-VP-S1 (2).
  7219. 081000     MOVE PHNO-ADJ-FCTR-3545-VP-I1 (3) TO
  7220. 081100           PHNO-ADJ-FCTR-3545-VP-S1 (3).
  7221. 081200     MOVE PHNO-ADJ-FCTR-3545-VP-I1 (4) TO
  7222. 081300           PHNO-ADJ-FCTR-3545-VP-S1 (4).
  7223. 081400     MOVE PHNO-ADJ-FCTR-3545-VP-I1 (5) TO
  7224. 081500           PHNO-ADJ-FCTR-3545-VP-S1 (5).
  7225. 081600     MOVE PHNO-ADJ-FCTR-3545-VP-I1 (6) TO
  7226. 081700           PHNO-ADJ-FCTR-3545-VP-S1 (6).
  7227. 081800     MOVE PHNO-ADJ-FCTR-3545-VP-I1 (7) TO
  7228. 081900           PHNO-ADJ-FCTR-3545-VP-S1 (7).
  7229. 082000     MOVE PHNO-ADJ-FCTR-3545-VP-I1 (8) TO
  7230. 082100           PHNO-ADJ-FCTR-3545-VP-S1 (8).
  7231. 082200     RELEASE  S-KEY4.
  7232. 082300 950-EXIT-VP.
  7233. 082400     EXIT.
  7234. 082500 1000-MV-VU-TO-SRT.
  7235. 082600     ADD 1 TO VU-CNT.
  7236. 082700     MOVE REC-TYPE-3529-VU-I1 TO REC-TYPE-3529-VU-S1.
  7237. 082800     MOVE FMT-NO-3576-VU-I1 TO FMT-NO-3576-VU-S1.
  7238. 082900     MOVE FMT-CD-3579-VU-I1 TO FMT-CD-3579-VU-S1.
  7239. 083000     MOVE ADM-UNIT-0003-VU-I1 TO ADM-UNIT-0003-VU-S1.
  7240. 083100     MOVE DATA-DT-6618-VU-I1 TO DATA-DT-6618-VU-S1.
  7241. 083200     MOVE ACT-CD-7350-VU-I1 TO ACT-CD-7350-VU-S1.
  7242. 083300     MOVE DUF-3917-VU-I1 TO DUF-3917-VU-S1.
  7243. 083400     MOVE LINE-NO-3578-VU-I1 TO LINE-NO-3578-VU-S1.
  7244. 083500     MOVE PLANT-CD-2646-VU-I1 TO PLANT-CD-2646-VU-S1.
  7245. 083600     MOVE AUF-3928-VU-I1 (1) TO AUF-3928-VU-S1 (1).
  7246. 083700     MOVE AUF-3928-VU-I1 (2) TO AUF-3928-VU-S1 (2).
  7247. 083800     MOVE AUF-3928-VU-I1 (3) TO AUF-3928-VU-S1 (3).
  7248. 083900     MOVE AUF-3928-VU-I1 (4) TO AUF-3928-VU-S1 (4).
  7249. 084000     MOVE AUF-3928-VU-I1 (5) TO AUF-3928-VU-S1 (5).
  7250. 084100     MOVE ANML-GRZG-CD-3929-VU-I1 TO ANML-GRZG-CD-3929-VU-S1.
  7251. 084200     MOVE PUF-3511-VU-I1 (1) TO PUF-3511-VU-S1 (1).
  7252. 084300     MOVE PUF-3511-VU-I1 (2) TO PUF-3511-VU-S1 (2).
  7253. 084400     MOVE PUF-3511-VU-I1 (3) TO PUF-3511-VU-S1 (3).
  7254. 084500     MOVE PUF-3511-VU-I1 (4) TO PUF-3511-VU-S1 (4).
  7255. 084600     MOVE PUF-3511-VU-I1 (5) TO PUF-3511-VU-S1 (5).
  7256. 084700     RELEASE  S-KEY5.
  7257. 084800 1050-EXIT-VU.
  7258. 084900     EXIT.
  7259. 085000 2000-RD-FILE2.
  7260. 085100     READ INPUT-FILE2  AT END MOVE 1 TO EOF-SWITCH.
  7261. 085200     IF (EOF-SWITCH = 1) GO TO 3000-EXIT-RD-FL2.
  7262. 085300     ADD 1 TO INPUT2-CNT.
  7263. 085400     MOVE REC-TYPE-3529-V7-I1 TO REC-TYPE-3529-V7-S1.
  7264. 085500     MOVE FMT-NO-3576-V7-I1 TO FMT-NO-3576-V7-S1.
  7265. 085600     MOVE FMT-CD-3579-V7-I1 TO FMT-CD-3579-V7-S1.
  7266. 085700     MOVE ADM-UNIT-0003-V7-I1 TO ADM-UNIT-0003-V7-S1.
  7267. 085800     MOVE DATA-DT-6618-V7-I1 TO DATA-DT-6618-V7-S1.
  7268. 085900     MOVE ACT-CD-7350-V7-I1 TO ACT-CD-7350-V7-S1.
  7269. 086000     MOVE LINE-NO-3578-V7-I1 TO LINE-NO-3578-V7-S1.
  7270. 086100     MOVE PLANT-CD-2646-V7-I1 (1) TO PLANT-CD1-2646-V7-S1.
  7271. 086200     MOVE PLANT-CD-2646-V7-I1 (1) TO PLANT-CD-2646-V7-S1 (1).
  7272. 086300     MOVE PLANT-CD-2646-V7-I1 (2) TO PLANT-CD-2646-V7-S1 (2).
  7273. 086400     MOVE PLANT-CD-2646-V7-I1 (3) TO PLANT-CD-2646-V7-S1 (3).
  7274. 086500     MOVE PLANT-CD-2646-V7-I1 (4) TO PLANT-CD-2646-V7-S1 (4).
  7275. 086600     MOVE PLANT-CD-2646-V7-I1 (5) TO PLANT-CD-2646-V7-S1 (5).
  7276. 086700     MOVE PLANT-CD-2646-V7-I1 (6) TO PLANT-CD-2646-V7-S1 (6).
  7277. 086800     MOVE PLANT-CD-2646-V7-I1 (7) TO PLANT-CD-2646-V7-S1 (7).
  7278. 086900     MOVE PLANT-CD-2646-V7-I1 (8) TO PLANT-CD-2646-V7-S1 (8).
  7279. 087000     MOVE PLANT-CD-2646-V7-I1 (9) TO PLANT-CD-2646-V7-S1 (9).
  7280. 087100     RELEASE  S-KEY2.
  7281. 087200 3000-EXIT-RD-FL2.
  7282. 087300     EXIT.
  7283. 087400 POST-SORT SECTION.
  7284. 087500 3050-RET-HSKPNG.
  7285. 087600     OPEN OUTPUT PRINT-FILE.
  7286. 087700     ACCEPT  PARAMETER.
  7287. 087800     ACCEPT  HOLD-DT FROM DATE.
  7288. 087900     MOVE YR-DT TO HDR-YR.
  7289. 088000     MOVE MON(MO-DT) TO HDR-MO.
  7290. 088100     MOVE DY-DT TO HDR-DA.
  7291. 088200     READY DIC-DE.
  7292. 088300     PERFORM 4000-VALIDATE-INV THRU 4050-EXIT-STDI.
  7293. 088400     RETURN  SORT-FILE AT END MOVE 1 TO EOR-SWITCH.
  7294. 088500     MOVE REC-TYPE-3529-V6-S1 TO HLD-REC-TYPE.
  7295. 088600     PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
  7296. 088700 3070-MAIN-DRIVER.
  7297. 088800     PERFORM 4300-DET-REC-LINE THRU 4350-EXIT-RET UNTIL EOR.
  7298. 088900     IF (EOR-SWITCH = 1)  GO TO 4830-DUMMY.
  7299. 089000 4000-VALIDATE-INV.
  7300. 089100     MOVE PARAMETER TO DE-CD-8822-DEC  HDR-INV-CD.
  7301. 089200     MOVE 3940 TO DE-NO-8801-DEC.
  7302. 089300     FIND ANY CODE-DEC.
  7303. 089400     MOVE DB-STATUS TO DB-STAT.
  7304. 089500     IF  NOT OK
  7305. 089600         MOVE "UNKNOWN" TO HDR-ST-NM HDR-DIST-NM HDR-INV-NM
  7306. 089700         GO  TO 4050-EXIT-STDI.
  7307. 089800     GET CODE-DEC.
  7308. 089900     MOVE DB-STATUS TO DB-STAT.
  7309. 090000     IF  NOT OK
  7310. 090100         DISPLAY "ES115PBD   DIDN'T GET INVN"
  7311. 090200         DISPLAY DB-STAT
  7312. 090300         GO  TO 4050-EXIT-STDI.
  7313. 090400     MOVE DE-CD-NAM-8823-DEC TO INV-HLD.
  7314. 090500     MOVE INV-NM TO HDR-INV-NM.
  7315. 090600 4005-VALIDATE-ST.
  7316. 090700     MOVE ST-CD-HLD TO DE-CD-8822-DEC  HDR-ST-CD.
  7317. 090800     MOVE 0003 TO DE-NO-8801-DEC.
  7318. 090900     FIND ANY CODE-DEC.
  7319. 091000     MOVE DB-STATUS TO DB-STAT.
  7320. 091100     IF NOT OK
  7321. 091200         MOVE "UNKNOWN" TO HDR-ST-NM
  7322. 091300         GO TO 4008-EXIT-ST.
  7323. 091400     GET CODE-DEC.
  7324. 091500     MOVE DB-STATUS TO DB-STAT.
  7325. 091600     IF NOT OK
  7326. 091700         DISPLAY "ES115PBD  3  DIDN'T GET ST"
  7327. 091800         DISPLAY "ES115PBD  4  " DB-STAT
  7328. 091900         GO TO 4008-EXIT-ST.
  7329. 092000     MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
  7330. 092100     MOVE ST-NM-HLD TO HDR-ST-NM.
  7331. 092200 4008-EXIT-ST.
  7332. 092300     EXIT.
  7333. 092400 4010-VALIDATE-STDI.
  7334. 092500     MOVE ST-DIST-CD TO DE-CD-8822-DEC.
  7335. 092600     MOVE DI-CD-HLD TO HDR-DIST-CD.
  7336. 092700     MOVE 0003 TO DE-NO-8801-DEC.
  7337. 092800     FIND ANY CODE-DEC.
  7338. 092900     MOVE DB-STATUS TO DB-STAT.
  7339. 093000     IF  NOT OK
  7340. 093100         MOVE "UNKNOWN" TO HDR-DIST-NM
  7341. 093200         GO  TO 4050-EXIT-STDI.
  7342. 093300     GET CODE-DEC.
  7343. 093400     MOVE DB-STATUS TO DB-STAT.
  7344. 093500     IF  NOT OK
  7345. 093600         DISPLAY "ES115PBD 5 DIDN'T GET STDI"
  7346. 093700         DISPLAY  "ES115PBD 6 " DB-STAT
  7347. 093800         GO  TO 4050-EXIT-STDI.
  7348. 093900     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  7349. 094000     MOVE DB-STATUS TO DB-STAT.
  7350. 094100     IF  NOT OK
  7351. 094200         MOVE "UNKNOWN" TO HDR-DIST-NM
  7352. 094300         GO  TO 4050-EXIT-STDI.
  7353. 094400     GET CODE-EXPL-DECE.
  7354. 094500     MOVE DB-STATUS TO DB-STAT.
  7355. 094600     IF  NOT OK
  7356. 094700         DISPLAY "ES115PBD  7 DIDN'T GET DIST"
  7357. 094800         DISPLAY  "ES115PBD 8  " DB-STAT
  7358. 094900         GO  TO 4050-EXIT-STDI.
  7359. 095000     MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD
  7360. 095100     MOVE DIST-NM-HLD TO HDR-DIST-NM.
  7361. 095200 4050-EXIT-STDI.
  7362. 095300     EXIT.
  7363. 095400 4100-CHK-LINE-CNT.
  7364. 095500     IF  LINE-CNT > 50
  7365. 095600         PERFORM 4200-PRT-HDNG THRU 4250-HDNG-EXIT
  7366. 095700         GO  TO 4150-EXIT-LINE-OVR50.
  7367. 095800 4150-EXIT-LINE-OVR50.
  7368. 095900     EXIT.
  7369. 096000 4200-PRT-HDNG.
  7370. 096100     ADD 1 TO PAGE-CNT.
  7371. 096200     MOVE PAGE-CNT TO HDR-PG.
  7372. 096300     WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
  7373. 096400     WRITE PRT-REC FROM HDR-2 AFTER ADVANCING 1 LINES.
  7374. 096500     WRITE PRT-REC FROM HDR-3 AFTER ADVANCING 1 LINES.
  7375. 096600     MOVE 2 TO LINE-CNT.
  7376. 096700 4220-CHK-WHAT-REC.
  7377. 096800     IF  HLD-REC-TYPE = "V6"
  7378. 096900         MOVE "V6" TO HDR-REC-TYPE
  7379. 097000         WRITE PRT-REC FROM HDR-4  AFTER ADVANCING 1 LINES
  7380. 097100         WRITE PRT-REC FROM HDR-5-V6 AFTER ADVANCING 2 LINES
  7381. 097200         WRITE PRT-REC FROM HDR-6-V6 AFTER ADVANCING 1 LINES
  7382. 097300         WRITE PRT-REC FROM HDR-7-V6 AFTER ADVANCING 1 LINES
  7383. 097400         WRITE PRT-REC FROM HDR-8-V6 AFTER ADVANCING 1 LINES
  7384. 097500         WRITE PRT-REC FROM HDR-9-V6 AFTER ADVANCING 1 LINES
  7385. 097600         GO TO 4230-PRT-SPACES.
  7386. 097700     IF  HLD-REC-TYPE = "V7"
  7387. 097800         MOVE "V7" TO HDR-REC-TYPE
  7388. 097900         WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
  7389. 098000         WRITE PRT-REC FROM HDR-5-V7 AFTER ADVANCING 2 LINES
  7390. 098100         WRITE PRT-REC FROM HDR-6-V7 AFTER ADVANCING 1 LINES
  7391. 098200         WRITE PRT-REC FROM HDR-7-V7 AFTER ADVANCING 1 LINES
  7392. 098300         WRITE PRT-REC FROM HDR-8-V7 AFTER ADVANCING 1 LINES
  7393. 098400         WRITE PRT-REC FROM HDR-9-V7 AFTER ADVANCING 1 LINES
  7394. 098500         GO TO 4230-PRT-SPACES.
  7395. 098600     IF  HLD-REC-TYPE = "VF"
  7396. 098700         MOVE "VF" TO HDR-REC-TYPE
  7397. 098800         WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
  7398. 098900         WRITE PRT-REC FROM HDR-5-VF AFTER ADVANCING 2 LINES
  7399. 099000         WRITE PRT-REC FROM HDR-6-VF AFTER ADVANCING 1 LINES
  7400. 099100         WRITE PRT-REC FROM HDR-7-VF AFTER ADVANCING 1 LINES
  7401. 099200         WRITE PRT-REC FROM HDR-8-VF AFTER ADVANCING 1 LINES
  7402. 099300         WRITE PRT-REC FROM HDR-9-VF AFTER ADVANCING 1 LINES
  7403. 099400         GO TO 4230-PRT-SPACES.
  7404. 099500     IF  HLD-REC-TYPE = "VP"
  7405. 099600         MOVE "VP" TO HDR-REC-TYPE
  7406. 099700         WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
  7407. 099800         WRITE PRT-REC FROM HDR-5-VP AFTER ADVANCING 2 LINES
  7408. 099900         WRITE PRT-REC FROM HDR-6-VP AFTER ADVANCING 1 LINES
  7409. 100000         WRITE PRT-REC FROM HDR-7-VP AFTER ADVANCING 1 LINES
  7410. 100100         WRITE PRT-REC FROM HDR-8-VP AFTER ADVANCING 1 LINES
  7411. 100200         WRITE PRT-REC FROM HDR-9-VP AFTER ADVANCING 1 LINES
  7412. 100300         GO TO 4230-PRT-SPACES.
  7413. 100400     IF  HLD-REC-TYPE = "VU"
  7414. 100500         MOVE "VU" TO HDR-REC-TYPE
  7415. 100600         WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
  7416. 100700         WRITE PRT-REC FROM HDR-5-VU AFTER ADVANCING 2 LINES
  7417. 100800         WRITE PRT-REC FROM HDR-6-VU AFTER ADVANCING 1 LINES
  7418. 100900         WRITE PRT-REC FROM HDR-7-VU AFTER ADVANCING 1 LINES
  7419. 101000         WRITE PRT-REC FROM HDR-8-VU AFTER ADVANCING 1 LINES
  7420. 101100         WRITE PRT-REC FROM HDR-9-VU AFTER ADVANCING 1 LINES.
  7421. 101200 4230-PRT-SPACES.
  7422. 101300     MOVE SPACES TO PRT-REC.
  7423. 101400     WRITE PRT-REC AFTER ADVANCING 1 LINES.
  7424. 101500     ADD 7 TO LINE-CNT.
  7425. 101600 4250-HDNG-EXIT.
  7426. 101700     EXIT.
  7427. 101800 4300-DET-REC-LINE.
  7428. 101900     IF  REC-TYPE-3529-V6-S1 = HLD-REC-TYPE
  7429. 102000         PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP
  7430. 102100         GO  TO 4320-RET-SORT.
  7431. 102200     IF REC-TYPE-3529-V6-S1 = "99"  GO TO 4350-EXIT-RET.
  7432. 102300     MOVE 66 TO LINE-CNT.
  7433. 102400     MOVE 0 TO PAGE-CNT.
  7434. 102500     MOVE REC-TYPE-3529-V6-S1 TO HLD-REC-TYPE.
  7435. 102600     PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP.
  7436. 102700 4320-RET-SORT.
  7437. 102800     RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH
  7438. 102900            MOVE "99" TO REC-TYPE-3529-V6-S1.
  7439. 103000    IF (EOR-SWITCH = 1) GO TO 4350-EXIT-RET.
  7440. 103100 4350-EXIT-RET.
  7441. 103200     EXIT.
  7442. 103300 4400-PRNT-DET-LINE.
  7443. 103400     PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
  7444. 103500     IF  HLD-REC-TYPE = "V6"
  7445. 103600         PERFORM 4500-PRNT-V6 THRU 4800-EXIT-PRT-DET
  7446. 103700         GO  TO  4450-EXIT-CHK-REC-TYP.
  7447. 103800     IF  HLD-REC-TYPE = "V7"
  7448. 103900         PERFORM 4550-PRNT-V7 THRU 4800-EXIT-PRT-DET
  7449. 104000         GO  TO 4450-EXIT-CHK-REC-TYP.
  7450. 104100     IF  HLD-REC-TYPE = "VF"
  7451. 104200         PERFORM 4600-PRNT-VF THRU 4800-EXIT-PRT-DET
  7452. 104300         GO  TO 4450-EXIT-CHK-REC-TYP.
  7453. 104400     IF  HLD-REC-TYPE = "VP"
  7454. 104500         PERFORM 4650-PRNT-VP THRU 4800-EXIT-PRT-DET
  7455. 104600         GO  TO 4450-EXIT-CHK-REC-TYP.
  7456. 104700     IF  HLD-REC-TYPE = "VU"
  7457. 104800         PERFORM 4700-PRNT-VU THRU 4800-EXIT-PRT-DET
  7458. 104900         GO TO 4450-EXIT-CHK-REC-TYP.
  7459. 105000 4450-EXIT-CHK-REC-TYP.
  7460. 105100     EXIT.
  7461. 105200 4500-PRNT-V6.
  7462. 105300     MOVE REC-TYPE-3529-V6-S1      TO  REC-TYPE-3529-V6-P1.
  7463. 105400     MOVE FMT-NO-3576-V6-S1        TO  FMT-NO-3576-V6-P1.
  7464. 105500     MOVE FMT-CD-3579-V6-S1        TO  FMT-CD-3579-V6-P1.
  7465. 105600     MOVE ADM-ST-0003-V6-S1        TO  ADM-ST-0003-V6-P1.
  7466. 105700     MOVE ADM-DI-0003-V6-S1        TO  ADM-DI-0003-V6-P1.
  7467. 105800     MOVE ADM-RA-0003-V6-S1        TO  ADM-RA-0003-V6-P1.
  7468. 105900     MOVE ADM-PU-0003-V6-S1        TO  ADM-PU-0003-V6-P1.
  7469. 106000     MOVE DATA-DT-6618-V6-S1       TO  DATA-DT-6618-V6-P1.
  7470. 106100     MOVE ACT-CD-7350-V6-S1        TO ACT-CD-7350-V6-P1.
  7471. 106200     MOVE LINE-NO-3578-V6-S1        TO  LINE-NO-3578-V6-P1.
  7472. 106300     MOVE PLANT-CD-2646-V6-S1      TO PLANT-CD-2646-V6-P1.
  7473. 106400     MOVE PHNO-STG-CD-3712-V6-S1   TO  PHNO-STG-CD-3712-V6-P1.
  7474. 106500     MOVE GRAMS-GRN-WGT-3941-V6-S1 TO  GRAMS-GRN-WGT-3941-V6-P1.
  7475. 106600     MOVE ADW-PCT-3546-V6-S1       TO  ADW-PCT-3546-V6-P1.
  7476. 106700     MOVE GRAMS-DRY-WGT-3942-V6-S1 TO  GRAMS-DRY-WGT-3942-V6-P1.
  7477. 106800     IF  BA-DIMS-MIN-3533-V6-S1 NOT = SPACES
  7478. 106900         MOVE BA-DIMS-MIN-RE-3533-V6-S1 TO
  7479. 107000            BA-DIMS-MIN-RE-3533-V6-P1
  7480. 107100     ELSE
  7481. 107200         MOVE BA-DIMS-MIN-3533-V6-S1 TO BA-DIMS-MIN-3533-V6-P1.
  7482. 107300     IF  BA-DIMS-MAX-3533-V6-S1 NOT = SPACES
  7483. 107400         MOVE BA-DIMS-MAX-RE-3533-V6-S1 TO
  7484. 107500            BA-DIMS-MAX-RE-3533-V6-P1
  7485. 107600     ELSE
  7486. 107700         MOVE BA-DIMS-MAX-3533-V6-S1 TO BA-DIMS-MAX-3533-V6-P1.
  7487. 107800     IF  CRN-DIMS-MIN-3534-V6-S1 NOT = SPACES
  7488. 107900       MOVE CRN-DIMS-MIN-RE-3534-V6-S1 TO
  7489. 108000          CRN-DIMS-MIN-RE-3534-V6-P1
  7490. 108100     ELSE
  7491. 108200       MOVE CRN-DIMS-MIN-3534-V6-S1 TO CRN-DIMS-MIN-3534-V6-P1.
  7492. 108300     IF  CRN-DIMS-MAX-3534-V6-S1 NOT = SPACES
  7493. 108400       MOVE CRN-DIMS-MAX-RE-3534-V6-S1 TO
  7494. 108500          CRN-DIMS-MAX-RE-3534-V6-P1
  7495. 108600     ELSE
  7496. 108700       MOVE CRN-DIMS-MAX-3534-V6-S1 TO CRN-DIMS-MAX-3534-V6-P1.
  7497. 108800     IF HGT-AVG-3504-V6-S1 NOT = SPACES
  7498. 108900         MOVE HGT-AVG-RE-3504-V6-S1 TO HGT-AVG-RE-3504-V6-P1
  7499. 109000     ELSE
  7500. 109100         MOVE HGT-AVG-3504-V6-S1 TO HGT-AVG-3504-V6-P1.
  7501. 109200     IF AVG-LDR-LGT-7313-V6-S1 NOT = SPACES
  7502. 109300         MOVE AVG-LDR-LGT-RE-7313-V6-S1 TO
  7503. 109400            AVG-LDR-LGT-RE-7313-V6-P1
  7504. 109500     ELSE
  7505. 109600         MOVE AVG-LDR-LGT-7313-V6-S1 TO AVG-LDR-LGT-7313-V6-P1.
  7506. 109700     WRITE PRT-REC FROM HDR-10-DET-V6 AFTER ADVANCING 2 LINES.
  7507. 109800     ADD 2 TO LINE-CNT.
  7508. 109900     GO TO 4800-EXIT-PRT-DET.
  7509. 110000 4550-PRNT-V7.
  7510. 110100     MOVE REC-TYPE-3529-V7-S1      TO  REC-TYPE-3529-V7-P1.
  7511. 110200     MOVE FMT-NO-3576-V7-S1        TO  FMT-NO-3576-V7-P1.
  7512. 110300     MOVE FMT-CD-3579-V7-S1        TO  FMT-CD-3579-V7-P1.
  7513. 110400     MOVE ADM-ST-0003-V7-S1        TO  ADM-ST-0003-V7-P1.
  7514. 110500     MOVE ADM-DI-0003-V7-S1        TO  ADM-DI-0003-V7-P1.
  7515. 110600     MOVE ADM-RA-0003-V7-S1        TO  ADM-RA-0003-V7-P1.
  7516. 110700     MOVE ADM-PU-0003-V7-S1        TO  ADM-PU-0003-V7-P1.
  7517. 110800     MOVE DATA-DT-6618-V7-S1       TO  DATA-DT-6618-V7-P1.
  7518. 110900     MOVE ACT-CD-7350-V7-S1        TO  ACT-CD-7350-V7-P1.
  7519. 111000     MOVE LINE-NO-3578-V7-S1       TO  LINE-NO-3578-V7-P1.
  7520. 111100     MOVE PLANT-CD-2646-V7-S1 (1)  TO  PLANT-CD1-2646-V7-P1.
  7521. 111200     MOVE PLANT-CD-2646-V7-S1 (2)  TO  PLANT-CD2-2646-V7-P1.
  7522. 111300     MOVE PLANT-CD-2646-V7-S1 (3)  TO  PLANT-CD3-2646-V7-P1.
  7523. 111400     MOVE PLANT-CD-2646-V7-S1 (4)  TO  PLANT-CD4-2646-V7-P1.
  7524. 111500     MOVE PLANT-CD-2646-V7-S1 (5)  TO  PLANT-CD5-2646-V7-P1.
  7525. 111600     MOVE PLANT-CD-2646-V7-S1 (6)  TO  PLANT-CD6-2646-V7-P1.
  7526. 111700     MOVE PLANT-CD-2646-V7-S1 (7)  TO  PLANT-CD7-2646-V7-P1.
  7527. 111800     MOVE PLANT-CD-2646-V7-S1 (8)  TO  PLANT-CD8-2646-V7-P1.
  7528. 111900     MOVE PLANT-CD-2646-V7-S1 (9)  TO PLANT-CD9-2646-V7-P1.
  7529. 112000     WRITE PRT-REC FROM HDR-10-DET-V7 AFTER ADVANCING 2 LINES.
  7530. 112100     ADD 2 TO LINE-CNT.
  7531. 112200     GO TO 4800-EXIT-PRT-DET.
  7532. 112300 4600-PRNT-VF.
  7533. 112400     MOVE REC-TYPE-3529-VF-S1      TO  REC-TYPE-3529-VF-P1.
  7534. 112500     MOVE FMT-NO-3576-VF-S1        TO  FMT-NO-3576-VF-P1.
  7535. 112600     MOVE FMT-CD-3579-VF-S1        TO  FMT-CD-3579-VF-P1.
  7536. 112700     MOVE ADM-ST-0003-VF-S1        TO  ADM-ST-0003-VF-P1.
  7537. 112800     MOVE ADM-DI-0003-VF-S1        TO  ADM-DI-0003-VF-P1.
  7538. 112900     MOVE DATA-DT-6618-VF-S1       TO  DATA-DT-6618-VF-P1.
  7539. 113000     MOVE ACT-CD-7350-VF-S1        TO  ACT-CD-7350-VF-P1.
  7540. 113100     MOVE LINE-NO-3578-VF-S1       TO  LINE-NO-3578-VF-P1.
  7541. 113200     MOVE ANML-GRZG-CD-3929-VF-S1  TO  ANML-GRZG-CD-3929-VF-P1.
  7542. 113300     PERFORM 4620-VALIDATE-ANML-CD THRU 4630-EXIT-ANML-CD.
  7543. 113400     MOVE MON-FORG-RQMT-3551-VF-S1 TO  MON-FORG-RQMT-3551-VF-P1.
  7544. 113500     PERFORM 4610-CHK-HGT-CLS THRU 4615-EXIT-HGT-CLS.
  7545. 113600     WRITE PRT-REC FROM HDR-10-DET-VF AFTER ADVANCING 2 LINES.
  7546. 113700     ADD 2 TO LINE-CNT.
  7547. 113800     GO TO 4800-EXIT-PRT-DET.
  7548. 113900 4610-CHK-HGT-CLS.
  7549. 114000     IF ANML-HGT-CLS-CD-3548-VF-S1 = "1"
  7550. 114100         MOVE SPACES TO ANML-HGT-3-4-3548-VF-P1
  7551. 114200             ANML-HGT-4-7-3548-VF-P1
  7552. 114300             ANML-HGT-7-OVR-3548-VF-P1
  7553. 114400             MOVE "1" TO ANML-HGT-0-3-3548-VF-P1
  7554. 114500             GO TO 4615-EXIT-HGT-CLS.
  7555. 114600     IF ANML-HGT-CLS-CD-3548-VF-S1 = "2"
  7556. 114700         MOVE SPACES TO ANML-HGT-0-3-3548-VF-P1
  7557. 114800             ANML-HGT-4-7-3548-VF-P1
  7558. 114900             ANML-HGT-7-OVR-3548-VF-P1
  7559. 115000             MOVE "2" TO ANML-HGT-3-4-3548-VF-P1
  7560. 115100             GO TO 4615-EXIT-HGT-CLS.
  7561. 115200     IF ANML-HGT-CLS-CD-3548-VF-S1 = "3"
  7562. 115300         MOVE SPACES TO ANML-HGT-0-3-3548-VF-P1
  7563. 115400             ANML-HGT-3-4-3548-VF-P1
  7564. 115500             ANML-HGT-7-OVR-3548-VF-P1
  7565. 115600             MOVE "3" TO ANML-HGT-4-7-3548-VF-P1
  7566. 115700             GO TO 4615-EXIT-HGT-CLS.
  7567. 115800     IF ANML-HGT-CLS-CD-3548-VF-S1 = "4"
  7568. 115900         MOVE SPACES TO ANML-HGT-0-3-3548-VF-P1
  7569. 116000             ANML-HGT-3-4-3548-VF-P1
  7570. 116100             ANML-HGT-4-7-3548-VF-P1
  7571. 116200             MOVE "4" TO ANML-HGT-7-OVR-3548-VF-P1
  7572. 116300             GO TO 4615-EXIT-HGT-CLS.
  7573. 116400 4615-EXIT-HGT-CLS.
  7574. 116500     EXIT.
  7575. 116600 4620-VALIDATE-ANML-CD.
  7576. 116700     MOVE ANML-GRZG-CD-3929-VF-S1 TO DE-CD-8822-DEC.
  7577. 116800     MOVE 3929 TO DE-NO-8801-DEC.
  7578. 116900     FIND ANY CODE-DEC.
  7579. 117000     MOVE DB-STATUS TO DB-STAT.
  7580. 117100     IF  NOT OK
  7581. 117200         MOVE "UNKNOWN" TO ANML-GRZG-NAME-VF-P1
  7582. 117300         GO  TO 4630-EXIT-ANML-CD.
  7583. 117400     GET CODE-DEC.
  7584. 117500     MOVE DB-STATUS TO DB-STAT.
  7585. 117600     IF  NOT OK
  7586. 117700         DISPLAY "ES115PBD  9  DIDN'T GET SPECIES CD"
  7587. 117800         DISPLAY "ES115PBD  10 " DB-STAT
  7588. 117900         GO TO 4630-EXIT-ANML-CD.
  7589. 118000     MOVE DE-CD-NAM-8823-DEC TO ANML-GRZG-NAME-VF-P1.
  7590. 118100 4630-EXIT-ANML-CD.
  7591. 118200     EXIT.
  7592. 118300 4650-PRNT-VP.
  7593. 118400     MOVE REC-TYPE-3529-VP-S1      TO  REC-TYPE-3529-VP-P1.
  7594. 118500     MOVE FMT-NO-3576-VP-S1        TO  FMT-NO-3576-VP-P1.
  7595. 118600     MOVE FMT-CD-3579-VP-S1        TO  FMT-CD-3579-VP-P1.
  7596. 118700     MOVE ADM-ST-0003-VP-S1        TO  ADM-ST-0003-VP-P1.
  7597. 118800     MOVE ADM-DI-0003-VP-S1        TO  ADM-DI-0003-VP-P1.
  7598. 118900     MOVE ADM-RA-0003-VP-S1        TO  ADM-RA-0003-VP-P1.
  7599. 119000     MOVE ADM-PU-0003-VP-S1        TO  ADM-PU-0003-VP-P1.
  7600. 119100     MOVE DATA-DT-6618-VP-S1       TO  DATA-DT-6618-VP-P1.
  7601. 119200     MOVE ACT-CD-7350-VP-S1        TO  ACT-CD-7350-VP-P1.
  7602. 119300     MOVE LINE-NO-3578-VP-S1       TO  LINE-NO-3578-VP-P1.
  7603. 119400     MOVE PLANT-CD-2646-VP-S1      TO  PLANT-CD-2646-VP-P1.
  7604. 119500     IF PHNO-ADJ-FCTR-3545-VP-S1 (1) NOT = SPACES
  7605. 119600     MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (1) TO
  7606. 119700         PHNO-ADJ-FCTR1-3545-VP-P1
  7607. 119800     ELSE
  7608. 119900         MOVE PHNO-ADJ-FCTR-3545-VP-S1 (1) TO
  7609. 120000             PHNO-ADJ-FCTR1-RE-3545-VP-P1.
  7610. 120100     IF PHNO-ADJ-FCTR-3545-VP-S1 (2) NOT = SPACES
  7611. 120200     MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (2) TO
  7612. 120300         PHNO-ADJ-FCTR2-3545-VP-P1
  7613. 120400     ELSE
  7614. 120500         MOVE PHNO-ADJ-FCTR-3545-VP-S1 (2) TO
  7615. 120600            PHNO-ADJ-FCTR2-RE-3545-VP-P1.
  7616. 120700     IF PHNO-ADJ-FCTR-3545-VP-S1 (3) NOT = SPACES
  7617. 120800     MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (3) TO
  7618. 120900         PHNO-ADJ-FCTR3-3545-VP-P1
  7619. 121000        ELSE
  7620. 121100            MOVE PHNO-ADJ-FCTR-3545-VP-S1 (3) TO
  7621. 121200                 PHNO-ADJ-FCTR3-RE-3545-VP-P1.
  7622. 121300     IF PHNO-ADJ-FCTR-3545-VP-S1 (4) NOT = SPACES
  7623. 121400     MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (4) TO
  7624. 121500         PHNO-ADJ-FCTR4-3545-VP-P1
  7625. 121600         ELSE
  7626. 121700             MOVE PHNO-ADJ-FCTR-3545-VP-S1 (4) TO
  7627. 121800                 PHNO-ADJ-FCTR4-RE-3545-VP-P1.
  7628. 121900     IF PHNO-ADJ-FCTR-3545-VP-S1 (5) NOT = SPACES
  7629. 122000     MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (5) TO
  7630. 122100         PHNO-ADJ-FCTR5-3545-VP-P1
  7631. 122200         ELSE
  7632. 122300             MOVE PHNO-ADJ-FCTR-3545-VP-S1 (5) TO
  7633. 122400                 PHNO-ADJ-FCTR5-RE-3545-VP-P1.
  7634. 122500     IF PHNO-ADJ-FCTR-3545-VP-S1 (6) NOT = SPACES
  7635. 122600     MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (6) TO
  7636. 122700         PHNO-ADJ-FCTR6-3545-VP-P1
  7637. 122800         ELSE
  7638. 122900             MOVE PHNO-ADJ-FCTR-3545-VP-S1 (6) TO
  7639. 123000                  PHNO-ADJ-FCTR6-RE-3545-VP-P1.
  7640. 123100     IF PHNO-ADJ-FCTR-3545-VP-S1 (7) NOT = SPACES
  7641. 123200     MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (7) TO
  7642. 123300         PHNO-ADJ-FCTR7-3545-VP-P1
  7643. 123400        ELSE
  7644. 123500         MOVE PHNO-ADJ-FCTR-3545-VP-S1 (7) TO
  7645. 123600             PHNO-ADJ-FCTR7-RE-3545-VP-P1.
  7646. 123700     IF PHNO-ADJ-FCTR-3545-VP-S1 (8) NOT = SPACES
  7647. 123800     MOVE PHNO-ADJ-FCTR-RE-3545-VP-S1 (8) TO
  7648. 123900         PHNO-ADJ-FCTR8-3545-VP-P1
  7649. 124000         ELSE
  7650. 124100             MOVE PHNO-ADJ-FCTR-3545-VP-S1 (8) TO
  7651. 124200              PHNO-ADJ-FCTR8-RE-3545-VP-P1.
  7652. 124300     WRITE PRT-REC FROM HDR-10-DET-VP AFTER ADVANCING 2 LINES.
  7653. 124400     ADD 2 TO LINE-CNT.
  7654. 124500     GO TO 4800-EXIT-PRT-DET.
  7655. 124600 4700-PRNT-VU.
  7656. 124700     MOVE REC-TYPE-3529-VU-S1      TO  REC-TYPE-3529-VU-P1.
  7657. 124800     MOVE FMT-NO-3576-VU-S1        TO  FMT-NO-3576-VU-P1.
  7658. 124900     MOVE FMT-CD-3579-VU-S1        TO  FMT-CD-3579-VU-P1.
  7659. 125000     MOVE ADM-ST-0003-VU-S1        TO  ADM-ST-0003-VU-P1.
  7660. 125100     MOVE ADM-DI-0003-VU-S1        TO  ADM-DI-0003-VU-P1.
  7661. 125200     MOVE ADM-RA-0003-VU-S1        TO  ADM-RA-0003-VU-P1.
  7662. 125300     MOVE ADM-PU-0003-VU-S1        TO  ADM-PU-0003-VU-P1.
  7663. 125400     MOVE DATA-DT-6618-VU-S1       TO  DATA-DT-6618-VU-P1.
  7664. 125500     MOVE ACT-CD-7350-VU-S1        TO  ACT-CD-7350-VU-P1.
  7665. 125600     MOVE LINE-NO-3578-VU-S1       TO  LINE-NO-3578-VU-P1.
  7666. 125700     MOVE PLANT-CD-2646-VU-S1      TO  PLANT-CD-2646-VU-P1.
  7667. 125800     MOVE AUF-3928-VU-S1 (1)       TO AUF1-3928-VU-P1.
  7668. 125900     MOVE AUF-3928-VU-S1 (2)       TO AUF2-3928-VU-P1.
  7669. 126000     MOVE AUF-3928-VU-S1 (3)       TO AUF3-3928-VU-P1.
  7670. 126100     MOVE AUF-3928-VU-S1 (4)       TO AUF4-3928-VU-P1.
  7671. 126200     MOVE AUF-3928-VU-S1 (5)       TO AUF5-3928-VU-P1.
  7672. 126300     MOVE ANML-GRZG-CD-3929-VU-S1  TO ANML-GRZG-CD-3929-VU-P1.
  7673. 126400     MOVE DUF-3917-VU-S1           TO DUF-3917-VU-P1.
  7674. 126500     MOVE PUF-3511-VU-S1 (1)       TO PUF1-3511-VU-P1.
  7675. 126600     MOVE PUF-3511-VU-S1 (2)       TO PUF2-3511-VU-P1.
  7676. 126700     MOVE PUF-3511-VU-S1 (3)       TO PUF3-3511-VU-P1.
  7677. 126800     MOVE PUF-3511-VU-S1 (4)       TO PUF4-3511-VU-P1.
  7678. 126900     MOVE PUF-3511-VU-S1 (5)       TO PUF5-3511-VU-P1.
  7679. 127000     WRITE PRT-REC FROM HDR-10-DET-VU AFTER ADVANCING 2 LINES.
  7680. 127100     ADD 2 TO LINE-CNT.
  7681. 127200 4800-EXIT-PRT-DET.
  7682. 127300     EXIT.
  7683. 127400 DUMMY-SECTION.
  7684. 127500 4830-DUMMY.
  7685. 127600     EXIT.
  7686. 127700 END-OF-JOB.
  7687. 000000*-----------------------------------------------------------------
  7688. 000100 IDENTIFICATION DIVISION.
  7689. 000200 PROGRAM-ID. ES120E.
  7690. 000300*        EDIT/UPDATE OF PLANTS (PHENO/WEIGHTS), ANIMALS (FORAGE/US
  7691. 000400*        FACTORS - V6, VF, VU, VP FORMATS.
  7692. 000500*
  7693. 000600 AUTHOR. RON BAKER.
  7694. 000700 DATE-WRITTEN.   08/23/79.
  7695. 000800 DATE-COMPILED.
  7696. 000900 ENVIRONMENT DIVISION.
  7697. 001000 CONFIGURATION SECTION.
  7698. 001100 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  7699. 001200 OBJECT-COMPUTER.  LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
  7700. 001300 INPUT-OUTPUT SECTION.
  7701. 001400 FILE-CONTROL.
  7702. 001500     SELECT FILE-D2          ASSIGN TO D1
  7703. 001600         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  7704. 001700     SELECT FILE-D1          ASSIGN TO I1
  7705. 001800         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  7706. 001900     SELECT FILE-P1          ASSIGN TO P1
  7707. 002000         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  7708. 002100 DATA DIVISION.
  7709. 002200 SUB-SCHEMA SECTION.
  7710. 002300 DB  CODVAL2 WITHIN BLMDIC.
  7711. 002400 FILE SECTION.
  7712. 002500 FD  FILE-D1
  7713. 002600     CODE-SET IS GBCD
  7714. 002700     LABEL RECORDS ARE STANDARD
  7715. 002800     DATA RECORD IS FDR-D1.
  7716. 002900 01  FDR-D1     PIC X(66).
  7717. 003000 FD  FILE-D2
  7718. 003100     CODE-SET IS GBCD
  7719. 003200     LABEL RECORDS ARE STANDARD
  7720. 003300     DATA RECORD IS FDR-D2.
  7721. 003400 01  FDR-D2       PIC X(66).
  7722. 003500 FD  FILE-P1
  7723. 003600     CODE-SET IS GBCD
  7724. 003700     LABEL RECORDS ARE STANDARD
  7725. 003800     DATA RECORD IS FDR-P1.
  7726. 003900 01  FDR-P1       PIC X(132).
  7727. 004000 WORKING-STORAGE SECTION.
  7728. 004100 77  ADST-CD-FLG  PIC 9  COMP-4.
  7729. 004200 77  DATA-DAT-CHG-FLG  PIC 9  COMP-4.
  7730. 004300 77  DATA-DAT-FLG  PIC 9  COMP-4  VALUE ZERO.
  7731. 004400 77  DIST-CD-FLG  PIC 9  COMP-4.
  7732. 004500 77  FRC-FLG  PIC 9  COMP-4.
  7733. 004600 77  INGR-FLG  PIC 9  COMP-4.
  7734. 004700 77  KEY-FLG  PIC 9  COMP-4.
  7735. 004800 77  ERR-FLG  PIC 9  COMP-4  VALUE ZERO.
  7736. 004900 77  AST-FLG  PIC 9  COMP-4  VALUE ZERO.
  7737. 005000 77  LIN-CHK  PIC 99  COMP-4.
  7738. 005100 77  LIN-CNT  PIC 99  COMP-4.
  7739. 005200 77  PHNO-CNT  PIC 99  COMP-4.
  7740. 005300 77  LIN-FLG  PIC 9  COMP-4  VALUE ZERO.
  7741. 005400 77  PAG-CNT  PIC 999  COMP-4.
  7742. 005500 77  PUF-CNT  PIC 999  COMP-4.
  7743. 005600 77  AUF-CNT  PIC 999  COMP-4.
  7744. 005700 77  PLANT-CD-FLG  PIC 9  COMP-4.
  7745. 005800 77  ANML-CD-FLG  PIC 9  COMP-4.
  7746. 005900 77  PLANT-TYP-FLG  PIC 9  COMP-4.
  7747. 006000 77  PLU-CD-FLG  PIC 9  COMP-4.
  7748. 006100 77  RITE-HDR-FLG  PIC 9  COMP-4.
  7749. 006200 77  RITE-KEY-FLG  PIC 9  COMP-4.
  7750. 006300 77  TEST-SW  PIC 9   VALUE 0 COMP-4.
  7751. 006400 77  HEAD-SW  PIC 9   VALUE 0 COMP-4.
  7752. 006500 77  SUB  PIC 99  COMP-4.
  7753. 006600 77  REC-SUB  PIC 99  COMP-4.
  7754. 006700 77  RASUB  PIC 9  COMP-4.
  7755. 006800 77  PHNO-SUB  PIC 9  COMP-4.
  7756. 006900 01  FDR-D1-WK.
  7757. 007000     03  CNTL-D1.
  7758. 007100         05  REC-TYP-D1    PIC XXXX.
  7759. 007200         05  SDRP-D1.
  7760. 007300             07 SDR-D1.
  7761. 007400                 09 SD-D1.
  7762. 007500                     11  ST-D1  PIC XX.
  7763. 007600                 11  DIST-D1 PIC XX.
  7764. 007700                 09  RA-D1   PIC XX.
  7765. 007800             07  PLU-D1    PIC XX.
  7766. 007900         05  DATE-D1   PIC X(6).
  7767. 008000         05  ACTN-D1   PIC X.
  7768. 008100         05  DIET-D1   PIC X.
  7769. 008200     03  DATA-D1    PIC X(46).
  7770. 008300 01 REC-TABLE.
  7771. 008400     03  FILLER PIC X(66) VALUE
  7772. 008500     "VP1DUT084806790901A0001ELSA   1122XXXX556677880099".
  7773. 008600     03  FILLER PIC X(66) VALUE
  7774. 008700     "VP1DUT089806790901A0002BADONE 11223344556677880099".
  7775. 008800     03  FILLER PIC X(66) VALUE
  7776. 008900     "VP1DUT084806790901A0003ELSA                 ".
  7777. 009000     03  FILLER PIC X(66) VALUE
  7778. 009100     "VP1DUT084806790901A0004ELSA   11223344556677880099".
  7779. 009200     03  FILLER PIC X(66) VALUE
  7780. 009300     "VP1DUT084806790901A0005ELSA   11223344556677880099".
  7781. 009400     03  FILLER PIC X(66) VALUE
  7782. 009500     "VP1DUT084806790901A0006ELSA   11223344556677880099".
  7783. 009600     03  FILLER PIC X(66) VALUE
  7784. 009700     "VP1DUT084806790901A0007ELSA   11223344556677880099".
  7785. 009800     03  FILLER PIC X(66) VALUE
  7786. 009900     "VP1DUT084806790901A0008ELSA   11223344556677880099".
  7787. 010000     03  FILLER PIC X(66) VALUE
  7788. 010100     "VP1DUT084806790901A0009ELSA   11223344556677880099".
  7789. 010200     03  FILLER PIC X(66) VALUE
  7790. 010300     "VP1DUT084806790901A0010ELSA   11223344556677880099".
  7791. 010400     03  FILLER PIC X(66) VALUE
  7792. 010500     "VP1DUT084806790901A0011ELSA   11223344556677880099".
  7793. 010600     03  FILLER PIC X(66) VALUE
  7794. 010700     "VP1DUT084806790901A0012ELSA   11223344556677880099".
  7795. 010800     03  FILLER PIC X(66) VALUE
  7796. 010900     "VP1DUT084806790901A0013ELSA   11223344556677880099".
  7797. 011000     03  FILLER PIC X(66) VALUE
  7798. 011100     "VP1DUT084806790901A0014ELSA   11223344556677880099".
  7799. 011200     03  FILLER PIC X(66) VALUE
  7800. 011300     "VP1DUT084806790901A0015ELSA   11223344556677880099".
  7801. 011400     03  FILLER PIC X(66) VALUE
  7802. 011500     "VP1DUT084806790901A0016ELSA   11223344556677880099".
  7803. 011600     03  FILLER PIC X(66) VALUE
  7804. 011700     "VP1DUT084806790901A0017ELSA   11223344556677880099".
  7805. 011800     03  FILLER PIC X(66) VALUE
  7806. 011900     "VP1DUT084806790901A0018ELSA   11223344556677880099".
  7807. 012000     03  FILLER PIC X(66) VALUE
  7808. 012100     "VP1DUT084806790901A0019ELSA   11223344556677880099".
  7809. 012200     03  FILLER PIC X(66) VALUE
  7810. 012300     "VP1DUT084806790901A0020ELSA   11223344556677880099".
  7811. 012400     03  FILLER PIC X(66) VALUE
  7812. 012500     "VP1DUT084806790901A0021ELSA   11223344556677880099".
  7813. 012600     03  FILLER PIC X(66) VALUE
  7814. 012700     "VP1DUT084806790901A0022ELSA   11223344556677880099".
  7815. 012800     03  FILLER PIC X(66) VALUE
  7816. 012900     "VP1DUT084806790901A0023ELSA   11223344556677880099".
  7817. 013000     03  FILLER PIC X(66) VALUE
  7818. 013100     "VP1DUT084806790901A0024ELSA   11223344556677880099".
  7819. 013200     03  FILLER PIC X(66) VALUE
  7820. 013300     "VP1DUT084806790901A0025ELSA   11223344556677880099".
  7821. 013400     03  FILLER PIC X(66) VALUE
  7822. 013500     "VP1DUT084806790901A0026ELSA   11223344556677880099".
  7823. 013600     03  FILLER PIC X(66) VALUE
  7824. 013700     "VP1DUT084806790901A0027ELSA   11223344556677880099".
  7825. 013800     03  FILLER PIC X(58) VALUE
  7826. 013900     "V61DUT084806790901A0001ELSA   1004410000221234234545675678".
  7827. 014000     03  FILLER PIC X(8) VALUE "91234   ".
  7828. 014100     03  FILLER PIC X(58) VALUE
  7829. 014200     "V61DUT084806790901A0002SSSS   9004410000221234234545675678".
  7830. 014300     03  FILLER PIC X(8) VALUE "91234   ".
  7831. 014400     03  FILLER PIC X(58) VALUE
  7832. 014500     "V61DUT088806790901A0003ELSA   1004410000221234234545675678".
  7833. 014600     03  FILLER PIC X(8) VALUE "91234   ".
  7834. 014700     03  FILLER PIC X(58) VALUE
  7835. 014800     "V61DUT088806790901A0004ELSA   1004410000221234234545675678".
  7836. 014900     03  FILLER PIC X(8) VALUE "91234   ".
  7837. 015000     03  FILLER PIC X(58) VALUE
  7838. 015100     "V61DUT088806790901A0005ELSA   1004410000221234234545675678".
  7839. 015200     03  FILLER PIC X(8) VALUE "91234   ".
  7840. 015300     03  FILLER PIC X(58) VALUE
  7841. 015400     "V61DUT088806790901A0006ELSA   1004410000221234234545675678".
  7842. 015500     03  FILLER PIC X(8) VALUE "91234   ".
  7843. 015600     03  FILLER PIC X(58) VALUE
  7844. 015700     "V61DUT088806790901A0007ELSA   1004410000221234234545675678".
  7845. 015800     03  FILLER PIC X(8) VALUE "91234   ".
  7846. 015900     03  FILLER PIC X(58) VALUE
  7847. 016000     "V61DUT088806790901A0008ELSA   1004410000221234234545675678".
  7848. 016100     03  FILLER PIC X(8) VALUE "91234   ".
  7849. 016200     03  FILLER PIC X(58) VALUE
  7850. 016300     "V61DUT088806790901A0009ELSA   1004410000221234234545675678".
  7851. 016400     03  FILLER PIC X(8) VALUE "91234   ".
  7852. 016500     03  FILLER PIC X(58) VALUE
  7853. 016600     "V61DUT088806790901A0010ELSA   1004410000221234234545675678".
  7854. 016700     03  FILLER PIC X(8) VALUE "91234   ".
  7855. 016800     03  FILLER PIC X(58) VALUE
  7856. 016900     "V61DUT088806790901A0011ELSA   1004410000221234234545675678".
  7857. 017000     03  FILLER PIC X(8) VALUE "91234   ".
  7858. 017100     03  FILLER PIC X(58) VALUE
  7859. 017200     "V61DUT088806790901A0012ELSA   1004410000221234234545675678".
  7860. 017300     03  FILLER PIC X(8) VALUE "91234   ".
  7861. 017400     03  FILLER PIC X(58) VALUE
  7862. 017500     "V61DUT088806790901A0013ELSA   1004410000221234234545675678".
  7863. 017600     03  FILLER PIC X(8) VALUE "91234   ".
  7864. 017700     03  FILLER PIC X(58) VALUE
  7865. 017800     "V61DUT088806790901A0014ELSA   1004410000221234234545675678".
  7866. 017900     03  FILLER PIC X(8) VALUE "91234   ".
  7867. 018000     03  FILLER PIC X(58) VALUE
  7868. 018100     "V61DUT088806790901A0015ELSA   1004410000221234234545675678".
  7869. 018200     03  FILLER PIC X(8) VALUE "91234   ".
  7870. 018300     03  FILLER PIC X(58) VALUE
  7871. 018400     "V61DUT088806790901A0016ELSA   1004410000221234234545675678".
  7872. 018500     03  FILLER PIC X(8) VALUE "91234   ".
  7873. 018600     03  FILLER PIC X(58) VALUE
  7874. 018700     "V61DUT088806790901A0017ELSA   1004410000221234234545675678".
  7875. 018800     03  FILLER PIC X(8) VALUE "91234   ".
  7876. 018900     03  FILLER PIC X(58) VALUE
  7877. 019000     "V61DUT088806790901A0018ELSA   1004410000221234234545675678".
  7878. 019100     03  FILLER PIC X(8) VALUE "91234   ".
  7879. 019200     03  FILLER PIC X(58) VALUE
  7880. 019300     "V61DUT088806790901A0019ELSA   1004410000221234234545675678".
  7881. 019400     03  FILLER PIC X(8) VALUE "91234   ".
  7882. 019500     03  FILLER PIC X(58) VALUE
  7883. 019600     "V61DUT088806790901A0020ELSA   1004410000221234234545675678".
  7884. 019700     03  FILLER PIC X(8) VALUE "91234   ".
  7885. 019800     03  FILLER PIC X(58) VALUE
  7886. 019900     "V61DUT088806790901A0021ELSA   1004410000221234234545675678".
  7887. 020000     03  FILLER PIC X(8) VALUE "91234   ".
  7888. 020100     03  FILLER PIC X(58) VALUE
  7889. 020200     "V61DUT088806790901A0022ELSA   1004410000221234234545675678".
  7890. 020300     03  FILLER PIC X(8) VALUE "91234   ".
  7891. 020400     03  FILLER PIC X(58) VALUE
  7892. 020500     "V61DUT088806790901A0023ELSA   1004410000221234234545675678".
  7893. 020600     03  FILLER PIC X(8) VALUE "91234   ".
  7894. 020700     03  FILLER PIC X(58) VALUE
  7895. 020800     "V61DUT088806790901A0024ELSA   1004410000221234234545675678".
  7896. 020900     03  FILLER PIC X(8) VALUE "91234   ".
  7897. 021000     03  FILLER PIC X(58) VALUE
  7898. 021100     "V61DUT088806790901A0025ELSA   1004410000221234234545675678".
  7899. 021200     03  FILLER PIC X(8) VALUE "91234   ".
  7900. 021300     03  FILLER PIC X(58) VALUE
  7901. 021400     "V61DUT088806790901A0026ELSA   1004410000221234234545675678".
  7902. 021500     03  FILLER PIC X(8) VALUE "91234   ".
  7903. 021600     03  FILLER PIC X(58) VALUE
  7904. 021700     "V61DUT088806790901A0027ELSA   1004410000221234234545675678".
  7905. 021800     03  FILLER PIC X(8) VALUE "91234   ".
  7906. 021900     03  FILLER PIC X(58) VALUE
  7907. 022000     "V61DUT088806790901A0028ELSA   1004410000221234234545675678".
  7908. 022100     03  FILLER PIC X(8) VALUE "91234   ".
  7909. 022200     03  FILLER PIC X(66) VALUE
  7910. 022300     "VF1DUT08    790901A0001CA12343".
  7911. 022400     03  FILLER PIC X(66) VALUE
  7912. 022500     "VF1DUT08    790901A0002ACAAAA9".
  7913. 022600     03  FILLER PIC X(66) VALUE
  7914. 022700     "VU1DUT084806790901AC0001BADONE 123456789123456CA00123456".
  7915. 022800     03  FILLER PIC X(66) VALUE
  7916. 022900     "VU1DUT084806790901AD0002PIED   BAD   789123456AC00BB3456".
  7917. 023000     03  FILLER PIC X(66) VALUE
  7918. 023100     "VU1DUT084806790901AP0003ELSA   123456789123456CA00123456".
  7919. 023200     03  FILLER PIC X(66) VALUE
  7920. 023300     "END ".
  7921. 023400     03  FILLER PIC X(66) VALUE
  7922. 023500     "END ".
  7923. 023600     03  FILLER PIC X(66) VALUE
  7924. 023700     "END ".
  7925. 023800 01  REC-TAB-RD REDEFINES REC-TABLE.
  7926. 023900     03  REC-TB   OCCURS  63 TIMES.
  7927. 024000         05  RT-RT    PIC XXXX.
  7928. 024100         05  DATA-RT   PIC X(62).
  7929. 024200*  "VF" FORAGE REQUIREMENT DATA.
  7930. 024400 01  REC-VF-X.
  7931. 024500     05  KEY-VF-X.
  7932. 024600         10  DIC-VF-X.
  7933. 024700             15  REC-TYP-3529-VF-X                PIC X(2).
  7934. 024800             15  FMT-NUM-3576-VF-X                PIC X(1).
  7935. 024900             15  FMT-CD-3579-VF-X                 PIC X(1).
  7936. 025000         10  BLM-ADM-U-0003-VF-X.
  7937. 025100             15  BLM-ADM-U-0003-ST-VF-X           PIC X(2).
  7938. 025200             15  BLM-ADM-U-0003-DIST-VF-X         PIC X(2).
  7939. 025300             15  FILLER                           PIC XXXX.
  7940. 025400         10  DATA-DATE-6618-VF-X.
  7941. 025500             15  DATA-DATE-6618-YY-VF-X           PIC X(2).
  7942. 025600             15  DATA-DATE-6618-MM-VF-X           PIC X(2).
  7943. 025700             15  DATA-DATE-6618-DD-VF-X           PIC X(2).
  7944. 025800         10  ACTN-CD-7350-VF-X                    PIC X(1).
  7945. 025900         10  LIN-NUM-3578-VF-X                    PIC X(4).
  7946. 026000*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  7947. 026100     05  ANML-GRZG-CD-3929-VF-X               PIC X(2).
  7948. 026200     05  MON-FORG-RQMT-LBS-3551-VF-X          PIC X(4).
  7949. 026300     05  ANML-HGT-CLS-CD-3548-VF-X            PIC X(1).
  7950. 026400     05  FILLER         PIC X(36).
  7951. 026600 01  REC-VF-Z.
  7952. 026700     05  KEY-VF-Z.
  7953. 026800         10  DIC-VF-Z.
  7954. 026900             15  REC-TYP-3529-VF-Z                PIC X(2).
  7955. 027000             15  FMT-NUM-3576-VF-Z                PIC X(1).
  7956. 027100             15  FMT-CD-3579-VF-Z                 PIC X(1).
  7957. 027200         10  BLM-ADM-U-0003-VF-Z.
  7958. 027300             15  BLM-ADM-U-0003-ST-VF-Z           PIC X(2).
  7959. 027400             15  BLM-ADM-U-0003-DIST-VF-Z         PIC X(2).
  7960. 027500             15  FILLER                           PIC XXXX.
  7961. 027600         10  DATA-DATE-6618-VF-Z.
  7962. 027700             15  DATA-DATE-6618-YY-VF-Z           PIC X(2).
  7963. 027800             15  DATA-DATE-6618-MM-VF-Z           PIC X(2).
  7964. 027900             15  DATA-DATE-6618-DD-VF-Z           PIC X(2).
  7965. 028000         10  ACTN-CD-7350-VF-Z                    PIC X(1).
  7966. 028100         10  LIN-NUM-3578-VF-Z                    PIC X(4).
  7967. 028200*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  7968. 028300     05  ANML-GRZG-CD-3929-VF-Z               PIC X(2).
  7969. 028400     05  MON-FORG-RQMT-LBS-3551-VF-Z          PIC X(4).
  7970. 028500     05  ANML-HGT-CLS-CD-3548-VF-Z            PIC X(1).
  7971. 028600     05  FILLER         PIC X(36).
  7972. 028700******************************************************************
  7973. 028800*  "VP" PHENOLOGY ADJUSTMENT DATA.
  7974. 029000 01  REC-VP-X.
  7975. 029100     05  KEY-VP-X.
  7976. 029200         10  DIC-VP-X.
  7977. 029300             15  REC-TYP-3529-VP-X                PIC X(2).
  7978. 029400             15  FMT-NUM-3576-VP-X                PIC X(1).
  7979. 029500             15  FMT-CD-3579-VP-X                 PIC X(1).
  7980. 029600         10  BLM-ADM-U-0003-VP-X.
  7981. 029700             15  BLM-ADM-U-0003-ST-VP-X           PIC X(2).
  7982. 029800             15  BLM-ADM-U-0003-DIST-VP-X         PIC X(2).
  7983. 029900             15  BLM-ADM-U-0003-RA-VP-X           PIC X(2).
  7984. 030000             15  BLM-ADM-U-0003-PLU-VP-X          PIC X(2).
  7985. 030100         10  DATA-DATE-6618-VP-X.
  7986. 030200             15  DATA-DATE-6618-YY-VP-X           PIC X(2).
  7987. 030300             15  DATA-DATE-6618-MM-VP-X           PIC X(2).
  7988. 030400             15  DATA-DATE-6618-DD-VP-X           PIC X(2).
  7989. 030500         10  ACTN-CD-7350-VP-X                    PIC X(1).
  7990. 030600         10  LIN-NUM-3578-VP-X                    PIC X(4).
  7991. 030700*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  7992. 030800     05  PLANT-CD-2646-VP-X                       PIC X(7).
  7993. 030900     05  PHNO-GP-VP-X     PIC X(32).
  7994. 031000     05  PHNO-ADJ-GP-VP-X REDEFINES PHNO-GP-VP-X.
  7995. 031100         07  PHNO-ADJ-VP-X  OCCURS 8 TIMES.
  7996. 031200             09  PHNO-ADJ-1-VP-X   PIC XX.
  7997. 031300             09  PHNO-ADJ-2-VP-X  PIC XX.
  7998. 031400     05  PHNO-ADJ-FCTR-3545-VP-X REDEFINES PHNO-GP-VP-X
  7999. 031500             OCCURS 8 TIMES     PIC 99V99.
  8000. 031600     05  PLANT-TYP-3590-VP-X    PIC X.
  8001. 031700     05  FILLER                   PIC XXXX.
  8002. 031900 01  REC-VP-Z.
  8003. 032000     05  KEY-VP-Z.
  8004. 032100         10  DIC-VP-Z.
  8005. 032200             15  REC-TYP-3529-VP-Z                PIC X(2).
  8006. 032300             15  FMT-NUM-3576-VP-Z                PIC X(1).
  8007. 032400             15  FMT-CD-3579-VP-Z                 PIC X(1).
  8008. 032500         10  BLM-ADM-U-0003-VP-Z.
  8009. 032600             15  BLM-ADM-U-0003-ST-VP-Z           PIC X(2).
  8010. 032700             15  BLM-ADM-U-0003-DIST-VP-Z         PIC X(2).
  8011. 032800             15  BLM-ADM-U-0003-RA-VP-Z           PIC X(2).
  8012. 032900             15  BLM-ADM-U-0003-PLU-VP-Z          PIC X(2).
  8013. 033000         10  DATA-DATE-6618-VP-Z.
  8014. 033100             15  DATA-DATE-6618-YY-VP-Z           PIC X(2).
  8015. 033200             15  DATA-DATE-6618-MM-VP-Z           PIC X(2).
  8016. 033300             15  DATA-DATE-6618-DD-VP-Z           PIC X(2).
  8017. 033400         10  ACTN-CD-7350-VP-Z                    PIC X(1).
  8018. 033500         10  LIN-NUM-3578-VP-Z                    PIC X(4).
  8019. 033600*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8020. 033700     05  PLANT-CD-2646-VP-Z                       PIC X(7).
  8021. 033800     05  PHNO-GP-VP-Z     PIC X(32).
  8022. 033900     05  PHNO-ADJ-GP-VP-Z REDEFINES PHNO-GP-VP-Z.
  8023. 034000         07  PHNO-ADJ-VP-Z  OCCURS 8 TIMES.
  8024. 034100             09  PHNO-ADJ-1-VP-Z   PIC XX.
  8025. 034200             09  PHNO-ADJ-2-VP-Z  PIC XX.
  8026. 034300     05  PHNO-ADJ-FCTR-3545-VP-Z REDEFINES PHNO-GP-VP-Z
  8027. 034400             OCCURS 8 TIMES     PIC 99V99.
  8028. 034500     05  PLANT-TYP-3590-VP-Z    PIC X.
  8029. 034600     05  FILLER                   PIC XXXX.
  8030. 034700******************************************************************
  8031. 034800*  "VU1D" DIET AND USE FACTORS BY ANIMAL AND SEASON.
  8032. 035000 01  REC-VU-X.
  8033. 035100     05  KEY-VU-X.
  8034. 035200         10  DIC-VU-X.
  8035. 035300             15  REC-TYP-3529-VU-X                PIC X(2).
  8036. 035400             15  FMT-NUM-3576-VU-X                PIC X(1).
  8037. 035500             15  FMT-CD-3579-VU-X                 PIC X(1).
  8038. 035600         10  BLM-ADM-U-0003-VU-X.
  8039. 035700             15  BLM-ADM-U-0003-ST-VU-X           PIC X(2).
  8040. 035800             15  BLM-ADM-U-0003-DIST-VU-X         PIC X(2).
  8041. 035900             15  BLM-ADM-U-0003-RA-VU-X           PIC X(2).
  8042. 036000             15  BLM-ADM-U-0003-PLU-VU-X          PIC X(2).
  8043. 036100         10  DATA-DATE-6618-VU-X.
  8044. 036200             15  DATA-DATE-6618-YY-VU-X           PIC X(2).
  8045. 036300             15  DATA-DATE-6618-MM-VU-X           PIC X(2).
  8046. 036400             15  DATA-DATE-6618-DD-VU-X           PIC X(2).
  8047. 036500         10  ACTN-CD-7350-VU-X                    PIC X(1).
  8048. 036600         10  DIET-USE-TYP-3917-VU-X               PIC X(1).
  8049. 036700         10  LIN-NUM-3578-VU-X                    PIC X(4).
  8050. 036800*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8051. 036900     05  PLANT-CD-2646-VU-X                       PIC X(7).
  8052. 037000     05  AUF-3928-VU-X-RD    PIC X(15).
  8053. 037100     05  AUF-3928-VU-X REDEFINES AUF-3928-VU-X-RD
  8054. 037200                        OCCURS 5 TIMES   PIC XXX.
  8055. 037300     05  ANML-GRZG-CD-3929-VU-X                   PIC X(2).
  8056. 037400     05  PUF-3511-VU-X-RD    PIC X(10).
  8057. 037500     05  PUF-3511-VU-X REDEFINES PUF-3511-VU-X-RD
  8058. 037600                        OCCURS 5 TIMES   PIC XX.
  8059. 037700     05  PLANT-TYP-3590-VU-X     PIC X.
  8060. 037800     05  FILLER                    PIC X(8).
  8061. 037900 01  REC-VU-Z.
  8062. 038000     05  KEY-VU-Z.
  8063. 038100         10  DIC-VU-Z.
  8064. 038200             15  REC-TYP-3529-VU-Z                PIC X(2).
  8065. 038300             15  FMT-NUM-3576-VU-Z                PIC X(1).
  8066. 038400             15  FMT-CD-3579-VU-Z                 PIC X(1).
  8067. 038500         10  BLM-ADM-U-0003-VU-Z.
  8068. 038600             15  BLM-ADM-U-0003-ST-VU-Z           PIC X(2).
  8069. 038700             15  BLM-ADM-U-0003-DIST-VU-Z         PIC X(2).
  8070. 038800             15  BLM-ADM-U-0003-RA-VU-Z           PIC X(2).
  8071. 038900             15  BLM-ADM-U-0003-PLU-VU-Z          PIC X(2).
  8072. 039000         10  DATA-DATE-6618-VU-Z.
  8073. 039100             15  DATA-DATE-6618-YY-VU-Z           PIC X(2).
  8074. 039200             15  DATA-DATE-6618-MM-VU-Z           PIC X(2).
  8075. 039300             15  DATA-DATE-6618-DD-VU-Z           PIC X(2).
  8076. 039400         10  ACTN-CD-7350-VU-Z                    PIC X(1).
  8077. 039500         10  DIET-USE-TYP-3917-VU-Z               PIC X(1).
  8078. 039600         10  LIN-NUM-3578-VU-Z                    PIC X(4).
  8079. 039700*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8080. 039800     05  PLANT-CD-2646-VU-Z                       PIC X(7).
  8081. 039900     05  AUF-3928-VU-Z            OCCURS  5 TIMES PIC X(3).
  8082. 040000     05  ANML-GRZG-CD-3929-VU-Z                   PIC X(2).
  8083. 040100     05  PUF-3511-VU-Z            OCCURS  5 TIMES PIC X(2).
  8084. 040200     05  PLANT-TYP-3590-VU-Z     PIC X.
  8085. 040300     05  FILLER                    PIC X(8).
  8086. 040400******************************************************************
  8087. 040500*  "V6" DRY/GREEN WEIGHT CONVERSION FACTOR DATA.
  8088. 040700 01  REC-V6-X.
  8089. 040800     05  KEY-V6-X.
  8090. 040900         10  DIC-V6-X.
  8091. 041000             15  REC-TYP-3529-V6-X                PIC X(2).
  8092. 041100             15  FMT-NUM-3576-V6-X                PIC X(1).
  8093. 041200             15  FMT-CD-3579-V6-X                 PIC X(1).
  8094. 041300         10  BLM-ADM-U-0003-V6-X.
  8095. 041400             15  BLM-ADM-U-0003-ST-V6-X           PIC X(2).
  8096. 041500             15  BLM-ADM-U-0003-DIST-V6-X         PIC X(2).
  8097. 041600             15  BLM-ADM-U-0003-RA-V6-X           PIC X(2).
  8098. 041700             15  BLM-ADM-U-0003-PLU-V6-X          PIC X(2).
  8099. 041800         10  DATA-DATE-6618-V6-X.
  8100. 041900             15  DATA-DATE-6618-YY-V6-X           PIC X(2).
  8101. 042000             15  DATA-DATE-6618-MM-V6-X           PIC X(2).
  8102. 042100             15  DATA-DATE-6618-DD-V6-X           PIC X(2).
  8103. 042200         10  ACTN-CD-7350-V6-X                    PIC X(1).
  8104. 042300         10  LIN-NUM-3578-V6-X                    PIC X(4).
  8105. 042400*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8106. 042500     05  PLANT-CD-2646-V6-X                       PIC X(7).
  8107. 042600     05  PHNO-STG-CD-3712-V6-X                    PIC X(1).
  8108. 042700     05  GRAMS-GRN-WGT-3941-V6-X                  PIC X(4).
  8109. 042800     05  ADW-PCT-3546-V6-X                        PIC X(3).
  8110. 042900     05  GRAMS-DRY-WGT-3942-V6-X                  PIC X(4).
  8111. 043000     05  GRP-1-V6-X.
  8112. 043100         07  BASAL-DIMS-3533-MIN-V6-X                 PIC 99V99.
  8113. 043200         07  BASAL-DIMS-3533-MAX-V6-X                 PIC 99V99.
  8114. 043300         07  CROWN-DIMS-3534-MIN-V6-X                 PIC 99V9.
  8115. 043400         07  CROWN-DIMS-3534-MAX-V6-X                 PIC 99V9.
  8116. 043500         07  HGT-AVG-3504-V6-X                        PIC 999V9.
  8117. 043600         07  AVG-LDR-LGT-7313-V6-X                    PIC 99V9.
  8118. 043700     05  GRP-1-RD-V6-X REDEFINES GRP-1-V6-X.
  8119. 043800         07  BASAL-DIMS-MIN-V6-X.
  8120. 043900             09  BAD-MIN-1-V6-X   PIC XX.
  8121. 044000             09  BAD-MIN-2-V6-X   PIC XX.
  8122. 044100         07  BASAL-DIMS-MAX-V6-X.
  8123. 044200             09  BAD-MAX-1-V6-X   PIC XX.
  8124. 044300             09  BAD-MAX-2-V6-X   PIC XX.
  8125. 044400         07  CROWN-DIMS-MIN-V6-X.
  8126. 044500             09  CRD-MIN-1-V6-X   PIC XX.
  8127. 044600             09  CRD-MIN-2-V6-X   PIC X.
  8128. 044700         07  CROWN-DIMS-MAX-V6-X.
  8129. 044800             09  CRD-MAX-1-V6-X   PIC XX.
  8130. 044900             09  CRD-MAX-2-V6-X   PIC X.
  8131. 045000         07  HGT-AVG-V6-X.
  8132. 045100             09  HGT-AVG-1-V6-X   PIC XXX.
  8133. 045200             09  HGT-AVG-2-V6-X   PIC X.
  8134. 045300         07  AVG-LDR-V6-X.
  8135. 045400             09  AVG-LDR-1-V6-X   PIC XX.
  8136. 045500             09  AVG-LDR-2-V6-X   PIC X.
  8137. 045600     05  PLANT-TYP-V6-X             PIC X.
  8138. 045700     05  REC-CNT-V6-X                     PIC 99.
  8139. 045800******************************************************************
  8140. 045900 01  REC-V6-Z.
  8141. 046000     05  KEY-V6-Z.
  8142. 046100         10  DIC-V6-Z.
  8143. 046200             15  REC-TYP-3529-V6-Z                PIC X(2).
  8144. 046300             15  FMT-NUM-3576-V6-Z                PIC X(1).
  8145. 046400             15  FMT-CD-3579-V6-Z                 PIC X(1).
  8146. 046500         10  BLM-ADM-U-0003-V6-Z.
  8147. 046600             15  BLM-ADM-U-0003-ST-V6-Z           PIC X(2).
  8148. 046700             15  BLM-ADM-U-0003-DIST-V6-Z         PIC X(2).
  8149. 046800             15  BLM-ADM-U-0003-RA-V6-Z           PIC X(2).
  8150. 046900             15  BLM-ADM-U-0003-PLU-V6-Z          PIC X(2).
  8151. 047000         10  DATA-DATE-6618-V6-Z.
  8152. 047100             15  DATA-DATE-6618-YY-V6-Z           PIC X(2).
  8153. 047200             15  DATA-DATE-6618-MM-V6-Z           PIC X(2).
  8154. 047300             15  DATA-DATE-6618-DD-V6-Z           PIC X(2).
  8155. 047400         10  ACTN-CD-7350-V6-Z                    PIC X(1).
  8156. 047500         10  LIN-NUM-3578-V6-Z                    PIC X(4).
  8157. 047600*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8158. 047700     05  PLANT-CD-2646-V6-Z                       PIC X(7).
  8159. 047800     05  PHNO-STG-CD-3712-V6-Z                    PIC X(1).
  8160. 047900     05  GRAMS-GRN-WGT-3941-V6-Z                  PIC X(4).
  8161. 048000     05  ADW-PCT-3546-V6-Z                        PIC X(3).
  8162. 048100     05  GRAMS-DRY-WGT-3942-V6-Z                  PIC X(4).
  8163. 048200     05  GRP-1-V6-Z.
  8164. 048300         07  BASAL-DIMS-3533-MIN-V6-Z                 PIC 99V99.
  8165. 048400         07  BASAL-DIMS-3533-MAX-V6-Z                 PIC 99V99.
  8166. 048500         07  CROWN-DIMS-3534-MIN-V6-Z                 PIC 99V9.
  8167. 048600         07  CROWN-DIMS-3534-MAX-V6-Z                 PIC 99V9.
  8168. 048700         07  HGT-AVG-3504-V6-Z                        PIC 999V9.
  8169. 048800         07  AVG-LDR-LGT-7313-V6-Z                    PIC 99V9.
  8170. 048900     05  GRP-1-RD-V6-Z REDEFINES GRP-1-V6-Z.
  8171. 049000         07  BASAL-DIMS-MIN-V6-Z                 PIC XXXX.
  8172. 049100         07  BASAL-DIMS-MAX-V6-Z                 PIC XXXX.
  8173. 049200         07  CROWN-DIMS-MIN-V6-Z                 PIC XXX.
  8174. 049300         07  CROWN-DIMS-MAX-V6-Z                 PIC XXX.
  8175. 049400         07  HGT-AVG-V6-Z                        PIC XXXX.
  8176. 049500         07  AVG-LDR-V6-Z                    PIC XXX.
  8177. 049600     05  PLANT-TYP-V6-Z             PIC X.
  8178. 049700     05  REC-CNT-V6-Z                     PIC 99.
  8179. 049800******************************************************************
  8180. 049900 01  REC-1-VF-P.
  8181. 050000     05  FILLER   PIC X(17)    VALUE SPACE.
  8182. 050100     05  REC-VF-P    PIC XXXX.
  8183. 050200     05  FILLER              PIC X(13)   VALUE SPACE.
  8184. 050300     05  ST-VF-P           PIC XX.
  8185. 050400     05  FILLER              PIC X(14)     VALUE SPACE.
  8186. 050500     05  DIST-VF-P         PIC XX.
  8187. 050600     05  FILLER              PIC X(11)    VALUE SPACE.
  8188. 050700     05  DATE-VF-P         PIC X(6).
  8189. 050800     05  FILLER              PIC X(13)     VALUE SPACE.
  8190. 050900     05  ACTN-VF-P         PIC X.
  8191. 051000     05  FILLER              PIC X(49)     VALUE SPACE.
  8192. 051100 01  REC-1-VF-AST.
  8193. 051200     05  FILLER   PIC X(17)    VALUE SPACE.
  8194. 051300     05  REC-VF-AST   PIC XXXX.
  8195. 051400     05  FILLER              PIC X(13)   VALUE SPACE.
  8196. 051500     05  ST-VF-AST          PIC XX.
  8197. 051600     05  FILLER              PIC X(14)     VALUE SPACE.
  8198. 051700     05  DIST-VF-AST        PIC XX.
  8199. 051800     05  FILLER              PIC X(11)    VALUE SPACE.
  8200. 051900     05  DATE-VF-AST        PIC X(6).
  8201. 052000     05  FILLER              PIC X(13)     VALUE SPACE.
  8202. 052100     05  ACTN-VF-AST        PIC X.
  8203. 052200     05  FILLER              PIC X(49)     VALUE SPACE.
  8204. 052300 01  REC-2-VF-P.
  8205. 052400     05  FILLER      PIC X(8)     VALUE SPACE.
  8206. 052500     05  LINE-VF-P        PIC XXXX.
  8207. 052600     05  FILLER      PIC X(8)   VALUE SPACE.
  8208. 052700     05  ANML-SP-VF-P    PIC XX.
  8209. 052800     05  FILLER      PIC X(8)     VALUE SPACE.
  8210. 052900     05  MON-FORG-VF-P    PIC XXXX.
  8211. 053000     05  FILLER      PIC X(14)     VALUE SPACE.
  8212. 053100     05  HT-CLS-AV-VF-P     PIC X.
  8213. 053200     05  FILLER      PIC X(83)     VALUE SPACE.
  8214. 053300 01  REC-2-VF-AST.
  8215. 053400     05  FILLER      PIC X(8)     VALUE SPACE.
  8216. 053500     05  LINE-VF-AST        PIC XXXX.
  8217. 053600     05  FILLER      PIC X(8)   VALUE SPACE.
  8218. 053700     05  ANML-SP-VF-AST    PIC XX.
  8219. 053800     05  FILLER      PIC X(8)     VALUE SPACE.
  8220. 053900     05  MON-FORG-VF-AST    PIC XXXX.
  8221. 054000     05  FILLER      PIC X(14)     VALUE SPACE.
  8222. 054100     05  HT-CLS-AV-VF-AST     PIC X.
  8223. 054200     05  FILLER      PIC X(83)     VALUE SPACE.
  8224. 054300******************************************************************
  8225. 054400 01  REC-1-V6P-P.
  8226. 054500     05  FILLER   PIC X(17)    VALUE SPACE.
  8227. 054600     05  REC-V6P-P    PIC XXXX.
  8228. 054700     05  FILLER              PIC X(13)   VALUE SPACE.
  8229. 054800     05  ST-V6P-P           PIC XX.
  8230. 054900     05  FILLER              PIC X(14)     VALUE SPACE.
  8231. 055000     05  DIST-V6P-P         PIC XX.
  8232. 055100     05  FILLER              PIC X(12)    VALUE SPACE.
  8233. 055200     05  RA-V6P-P     PIC XX.
  8234. 055300     05  FILLER         PIC X(15)     VALUE SPACE.
  8235. 055400     05  PLU-V6P-P        PIC XX.
  8236. 055500     05  FILLER      PIC X(13)     VALUE SPACE.
  8237. 055600     05  DATE-V6P-P         PIC X(6).
  8238. 055700     05  FILLER              PIC X(13)     VALUE SPACE.
  8239. 055800     05  ACTN-V6P-P         PIC X.
  8240. 055900     05  FILLER              PIC X(16)     VALUE SPACE.
  8241. 056000 01  REC-1-V6P-AST.
  8242. 056100     05  FILLER   PIC X(17)    VALUE SPACE.
  8243. 056200     05  REC-V6P-AST    PIC XXXX.
  8244. 056300     05  FILLER              PIC X(13)   VALUE SPACE.
  8245. 056400     05  ST-V6P-AST           PIC XX.
  8246. 056500     05  FILLER              PIC X(14)     VALUE SPACE.
  8247. 056600     05  DIST-V6P-AST         PIC XX.
  8248. 056700     05  FILLER              PIC X(12)    VALUE SPACE.
  8249. 056800     05  RA-V6P-AST     PIC XX.
  8250. 056900     05  FILLER         PIC X(15)     VALUE SPACE.
  8251. 057000     05  PLU-V6P-AST        PIC XX.
  8252. 057100     05  FILLER      PIC X(13)     VALUE SPACE.
  8253. 057200     05  DATE-V6P-AST         PIC X(6).
  8254. 057300     05  FILLER              PIC X(13)     VALUE SPACE.
  8255. 057400     05  ACTN-V6P-AST         PIC X.
  8256. 057500     05  FILLER              PIC X(16)     VALUE SPACE.
  8257. 057600 01  REC-2-V6-P.
  8258. 057700     05  FILLER        PIC X(5)    VALUE SPACE.
  8259. 057800     05  LINE-V6-P     PIC XXXX.
  8260. 057900     05  FILLER   PIC X(3)    VALUE SPACE.
  8261. 058000     05  PLANT-CD-V6-P  PIC X(7).
  8262. 058100     05  FILLER   PIC X(4)    VALUE SPACE.
  8263. 058200     05  PHNO-V6-P     PIC X.
  8264. 058300     05  FILLER   PIC X(6)    VALUE SPACE.
  8265. 058400     05  GRN-WGT-V6-P       PIC XXXX.
  8266. 058500     05  FILLER   PIC X(7)    VALUE SPACE.
  8267. 058600     05  PCT-DW-V6-P      PIC XXX.
  8268. 058700     05  FILLER   PIC X(7)    VALUE SPACE.
  8269. 058800     05  DW-V6-P          PIC XXXX.
  8270. 058900     05  FILLER   PIC X(7)    VALUE SPACE.
  8271. 059000     05  MIN-BAD-V6-P1       PIC XX.
  8272. 059100     05  MIN-BAD-V6-P2       PIC X.
  8273. 059200     05  MIN-BAD-V6-P3       PIC XX.
  8274. 059300     05  FILLER   PIC X(7)    VALUE SPACE.
  8275. 059400     05  MAX-BAD-V6-P1       PIC XX.
  8276. 059500     05  MAX-BAD-V6-P2       PIC X.
  8277. 059600     05  MAX-BAD-V6-P3       PIC XX.
  8278. 059700     05  FILLER   PIC X(10)    VALUE SPACE.
  8279. 059800     05  MIN-CRND-V6-P1      PIC XX.
  8280. 059900     05  MIN-CRND-V6-P2      PIC X.
  8281. 060000     05  MIN-CRND-V6-P3      PIC X.
  8282. 060100     05  FILLER   PIC X(10)    VALUE SPACE.
  8283. 060200     05  MAX-CRND-V6-P1      PIC XX.
  8284. 060300     05  MAX-CRND-V6-P2      PIC X.
  8285. 060400     05  MAX-CRND-V6-P3      PIC X.
  8286. 060500     05  FILLER   PIC X(5)    VALUE SPACE.
  8287. 060600     05  HGT-V6-P1           PIC XXX.
  8288. 060700     05  HGT-V6-P2           PIC X.
  8289. 060800     05  HGT-V6-P3           PIC X.
  8290. 060900     05  FILLER   PIC X(7)    VALUE SPACE.
  8291. 061000     05  AVG-LDR-V6-P1       PIC XX.
  8292. 061100     05  AVG-LDR-V6-P2       PIC X.
  8293. 061200     05  AVG-LDR-V6-P3       PIC X.
  8294. 061300     05  FILLER   PIC XX    VALUE SPACE.
  8295. 061400     05  REC-CNT-V6-P                     PIC 99.
  8296. 061500 01  REC-2-V6-AST.
  8297. 061600     05  FILLER        PIC X(5)    VALUE SPACE.
  8298. 061700     05  LINE-V6-AST     PIC XXXX.
  8299. 061800     05  FILLER   PIC X(3)    VALUE SPACE.
  8300. 061900     05  PLANT-CD-V6-AST  PIC X(7).
  8301. 062000     05  FILLER   PIC X(4)    VALUE SPACE.
  8302. 062100     05  PHNO-V6-AST     PIC X.
  8303. 062200     05  FILLER   PIC X(6)    VALUE SPACE.
  8304. 062300     05  GRN-WGT-V6-AST       PIC XXXX.
  8305. 062400     05  FILLER   PIC X(7)    VALUE SPACE.
  8306. 062500     05  PCT-DW-V6-AST      PIC XXX.
  8307. 062600     05  FILLER   PIC X(7)    VALUE SPACE.
  8308. 062700     05  DW-V6-AST          PIC XXXX.
  8309. 062800     05  FILLER   PIC X(7)    VALUE SPACE.
  8310. 062900     05  MIN-BAD-V6-AST       PIC XXBXX.
  8311. 063000     05  FILLER   PIC X(7)    VALUE SPACE.
  8312. 063100     05  MAX-BAD-V6-AST       PIC XXBXX.
  8313. 063200     05  FILLER   PIC X(10)    VALUE SPACE.
  8314. 063300     05  MIN-CRND-V6-AST      PIC XXBX.
  8315. 063400     05  FILLER   PIC X(10)    VALUE SPACE.
  8316. 063500     05  MAX-CRND-V6-AST      PIC XXBX.
  8317. 063600     05  FILLER   PIC X(5)    VALUE SPACE.
  8318. 063700     05  HGT-V6-AST           PIC XXXBX.
  8319. 063800     05  FILLER   PIC X(7)    VALUE SPACE.
  8320. 063900     05  AVG-LDR-V6-AST       PIC XXBX.
  8321. 064000     05  FILLER   PIC X(4)    VALUE SPACE.
  8322. 064100******************************************************************
  8323. 064200 01  REC-2-VP-P.
  8324. 064300     05  FILLER        PIC X(8)    VALUE SPACE.
  8325. 064400     05  LINE-VP-P     PIC XXXX.
  8326. 064500     05  FILLER   PIC X(8)    VALUE SPACE.
  8327. 064600     05  PLANT-CD-VP-P  PIC X(7).
  8328. 064700     05  FILLER   PIC X(6)    VALUE SPACE.
  8329. 064800     05  PHNO-PCT-VP-P         OCCURS 8 TIMES.
  8330. 064900         07  PHNO-PCT-VP-P1  PIC XX.
  8331. 065000         07  PHNO-PCT-VP-P2  PIC X.
  8332. 065100         07  PHNO-PCT-VP-P3  PIC XX.
  8333. 065200         07  FILLER          PIC X(7).
  8334. 065300     05  FILLER          PIC XXX   VALUE SPACE.
  8335. 065400 01  REC-2-VP-AST.
  8336. 065500     05  FILLER        PIC X(8)    VALUE SPACE.
  8337. 065600     05  LINE-VP-AST     PIC XXXX.
  8338. 065700     05  FILLER   PIC X(8)    VALUE SPACE.
  8339. 065800     05  PLANT-CD-VP-AST  PIC X(7).
  8340. 065900     05  FILLER   PIC X(6)    VALUE SPACE.
  8341. 066000     05  PHNO-PCT-VP-AST         OCCURS 8 TIMES PIC XXBX(9).
  8342. 066100     05  FILLER          PIC XXX   VALUE SPACE.
  8343. 066200******************************************************************
  8344. 066300 01  REC-1-VU-P.
  8345. 066400     05  FILLER   PIC X(12)    VALUE SPACE.
  8346. 066500     05  REC-VU-P    PIC XXXX.
  8347. 066600     05  FILLER              PIC X(13)   VALUE SPACE.
  8348. 066700     05  ST-VU-P           PIC XX.
  8349. 066800     05  FILLER              PIC X(14)     VALUE SPACE.
  8350. 066900     05  DIST-VU-P         PIC XX.
  8351. 067000     05  FILLER              PIC X(12)    VALUE SPACE.
  8352. 067100     05  RA-VU-P     PIC XX.
  8353. 067200     05  FILLER         PIC X(15)     VALUE SPACE.
  8354. 067300     05  PLU-VU-P        PIC XX.
  8355. 067400     05  FILLER      PIC X(13)     VALUE SPACE.
  8356. 067500     05  DATE-VU-P         PIC X(6).
  8357. 067600     05  FILLER              PIC X(13)     VALUE SPACE.
  8358. 067700     05  ACTN-VU-P         PIC X.
  8359. 067800     05  FILLER              PIC X(10)     VALUE SPACE.
  8360. 067900     05  PUFDT-VU-P        PIC X.
  8361. 068000     05  FILLER              PIC X(10)     VALUE SPACE.
  8362. 068100 01  REC-1-VU-AST.
  8363. 068200     05  FILLER   PIC X(12)    VALUE SPACE.
  8364. 068300     05  REC-VU-AST    PIC XXXX.
  8365. 068400     05  FILLER              PIC X(13)   VALUE SPACE.
  8366. 068500     05  ST-VU-AST           PIC XX.
  8367. 068600     05  FILLER              PIC X(14)     VALUE SPACE.
  8368. 068700     05  DIST-VU-AST         PIC XX.
  8369. 068800     05  FILLER              PIC X(12)    VALUE SPACE.
  8370. 068900     05  RA-VU-AST     PIC XX.
  8371. 069000     05  FILLER         PIC X(15)     VALUE SPACE.
  8372. 069100     05  PLU-VU-AST        PIC XX.
  8373. 069200     05  FILLER      PIC X(13)     VALUE SPACE.
  8374. 069300     05  DATE-VU-AST         PIC X(6).
  8375. 069400     05  FILLER              PIC X(13)     VALUE SPACE.
  8376. 069500     05  ACTN-VU-AST         PIC X.
  8377. 069600     05  FILLER              PIC X(10)     VALUE SPACE.
  8378. 069700     05  PUFDT-VU-AST        PIC X.
  8379. 069800     05  FILLER              PIC X(10)     VALUE SPACE.
  8380. 069900 01  REC-2-VU-P.
  8381. 070000     05  FILLER        PIC X(8)    VALUE SPACE.
  8382. 070100     05  LINE-VU-P     PIC XXXX.
  8383. 070200     05  FILLER   PIC X(3)    VALUE SPACE.
  8384. 070300     05  PLANT-CD-VU-P  PIC X(7).
  8385. 070400     05  FILLER   PIC X(4)    VALUE SPACE.
  8386. 070500     05  AUF-GP-P.
  8387. 070600         07  PLNT-SPG-VU-P     PIC XXX.
  8388. 070700         07  FILLER          PIC X(5)   VALUE SPACE.
  8389. 070800         07  PLNT-SUM-VU-P     PIC XXX.
  8390. 070900         07  FILLER          PIC X(5)   VALUE SPACE.
  8391. 071000         07  PLNT-FAL-VU-P     PIC XXX.
  8392. 071100         07  FILLER          PIC X(5)   VALUE SPACE.
  8393. 071200         07  PLNT-WIN-VU-P     PIC XXX.
  8394. 071300         07  FILLER          PIC X(5)   VALUE SPACE.
  8395. 071400         07  PLNT-YRL-VU-P     PIC XXX.
  8396. 071500         07  FILLER          PIC X(5)   VALUE SPACE.
  8397. 071600     05  AUF-GP-RD-P REDEFINES AUF-GP-P  OCCURS 5 TIMES.
  8398. 071700         07  AUF-PCT-VU-P   PIC XXX.
  8399. 071800         07  FILLER    PIC XXXXX.
  8400. 071900     05  FILLER    PIC XXX.
  8401. 072000     05  ANML-SP-VU-P     PIC XX.
  8402. 072100     05  FILLER          PIC X(7)   VALUE SPACE.
  8403. 072200     05  PUF-GP-P.
  8404. 072300         07  ANML-SPG-VU-P     PIC XX.
  8405. 072400         07  FILLER          PIC X(7)   VALUE SPACE.
  8406. 072500         07  ANML-SUM-VU-P     PIC XX.
  8407. 072600         07  FILLER          PIC X(7)   VALUE SPACE.
  8408. 072700         07  ANML-FAL-VU-P     PIC XX.
  8409. 072800         07  FILLER          PIC X(7)   VALUE SPACE.
  8410. 072900         07  ANML-WIN-VU-P      PIC XX.
  8411. 073000         07  FILLER          PIC X(7)   VALUE SPACE.
  8412. 073100         07  ANML-YRL-VU-P     PIC XX.
  8413. 073200         07  FILLER   PIC X(7)     VALUE SPACE.
  8414. 073300     05  PUF-GP-RD-P REDEFINES PUF-GP-P  OCCURS 5 TIMES.
  8415. 073400         07  PUF-VU-P   PIC XX.
  8416. 073500         07  FILLER    PIC X(7).
  8417. 073600     05  FILLER   PIC X(8)     VALUE SPACE.
  8418. 073700******************************************************************
  8419. 073800 01  REC-2-VU-AST.
  8420. 073900     05  FILLER        PIC X(8)    VALUE SPACE.
  8421. 074000     05  LINE-VU-AST     PIC XXXX.
  8422. 074100     05  FILLER   PIC X(3)    VALUE SPACE.
  8423. 074200     05  PLANT-CD-VU-AST  PIC X(7).
  8424. 074300     05  FILLER   PIC X(4)    VALUE SPACE.
  8425. 074400     05  AUF-GP-AST.
  8426. 074500         07  PLNT-SPG-VU-AST     PIC XXX.
  8427. 074600         07  FILLER          PIC X(5)   VALUE SPACE.
  8428. 074700         07  PLNT-SUM-VU-AST     PIC XXX.
  8429. 074800         07  FILLER          PIC X(5)   VALUE SPACE.
  8430. 074900         07  PLNT-FAL-VU-AST     PIC XXX.
  8431. 075000         07  FILLER          PIC X(5)   VALUE SPACE.
  8432. 075100         07  PLNT-WIN-VU-AST     PIC XXX.
  8433. 075200         07  FILLER          PIC X(5)   VALUE SPACE.
  8434. 075300         07  PLNT-YRL-VU-AST     PIC XXX.
  8435. 075400         07  FILLER          PIC X(5)   VALUE SPACE.
  8436. 075500     05  AUF-GP-RD-AST REDEFINES AUF-GP-AST  OCCURS 5 TIMES.
  8437. 075600         07  AUF-PCT-VU-AST   PIC XXX.
  8438. 075700         07  FILLER    PIC XXXXX.
  8439. 075800     05  FILLER    PIC XXX.
  8440. 075900     05  ANML-SP-VU-AST     PIC XX.
  8441. 076000     05  FILLER          PIC X(7)   VALUE SPACE.
  8442. 076100     05  PUF-GP-AST.
  8443. 076200         07  ANML-SPG-VU-AST     PIC XX.
  8444. 076300         07  FILLER          PIC X(7)   VALUE SPACE.
  8445. 076400         07  ANML-SUM-VU-AST     PIC XX.
  8446. 076500         07  FILLER          PIC X(7)   VALUE SPACE.
  8447. 076600         07  ANML-FAL-VU-AST     PIC XX.
  8448. 076700         07  FILLER          PIC X(7)   VALUE SPACE.
  8449. 076800         07  ANML-WIN-VU-AST      PIC XX.
  8450. 076900         07  FILLER          PIC X(7)   VALUE SPACE.
  8451. 077000         07  ANML-YRL-VU-AST     PIC XX.
  8452. 077100         07  FILLER   PIC X(7)     VALUE SPACE.
  8453. 077200     05  PUF-GP-RD-AST REDEFINES PUF-GP-AST  OCCURS 5 TIMES.
  8454. 077300         07  PUF-VU-AST   PIC XX.
  8455. 077400         07  FILLER    PIC X(7).
  8456. 077500     05  FILLER   PIC X(8)     VALUE SPACE.
  8457. 077600******************************************************************
  8458. 077700*01  REC-2-VU-AST.
  8459. 077800*    05  FILLER        PIC X(8)    VALUE SPACE.
  8460. 077900*    05  LINE-VP-AST     PIC XXXX.
  8461. 078000*    05  FILLER   PIC X(3)    VALUE SPACE.
  8462. 078100*    05  PLANT-CD-VU-AST  PIC X(7).
  8463. 078200*    05  FILLER   PIC X(3)    VALUE SPACE.
  8464. 078300*    05  PLNT-SPG-VU-AST     PIC XXX.
  8465. 078400*    05  FILLER          PIC X(6)   VALUE SPACE.
  8466. 078500*    05  PLNT-SUM-VU-AST     PIC XXX.
  8467. 078600*    05  FILLER          PIC X(5)   VALUE SPACE.
  8468. 078700*    05  PLNT-FAL-VU-AST     PIC XXX.
  8469. 078800*    05  FILLER          PIC X(5)   VALUE SPACE.
  8470. 078900*    05  PLNT-WIN-VU-AST     PIC XXX.
  8471. 079000*    05  FILLER          PIC X(5)   VALUE SPACE.
  8472. 079100*    05  PLNT-YRL-VU-AST     PIC XXX.
  8473. 079200*    05  FILLER          PIC X(8)   VALUE SPACE.
  8474. 079300*    05  ANML-SP-VU-AST     PIC XX.
  8475. 079400*    05  FILLER          PIC X(7)   VALUE SPACE.
  8476. 079500*    05  ANML-SPG-VU-AST     PIC XX.
  8477. 079600*    05  FILLER          PIC X(7)   VALUE SPACE.
  8478. 079700*    05  ANML-SUM-VU-AST     PIC XX.
  8479. 079800*    05  FILLER          PIC X(7)   VALUE SPACE.
  8480. 079900*    05  ANML-FAL-VU-AST     PIC XX.
  8481. 080000*    05  FILLER          PIC X(7)   VALUE SPACE.
  8482. 080100*    05  ANML-WIN-VU-AST      PIC XX.
  8483. 080200*    05  FILLER          PIC X(7)   VALUE SPACE.
  8484. 080300*    05  ANML-YRL-VU-AST     PIC XX.
  8485. 080400*    05  FILLER   PIC X(15)     VALUE SPACE.
  8486. 080500******************************************************************
  8487. 080600 01  HDR-1.
  8488. 080700     05  FILLER  PIC X(24)  VALUE "    PCN: ES120E   AS OF ".
  8489. 080800     05  HDR-DD        PIC XX.
  8490. 080900     05  FILLER        PIC X         VALUE SPACE.
  8491. 081000     05  HDR-MMM       PIC XXX.
  8492. 081100     05  FILLER        PIC X         VALUE SPACE.
  8493. 081200     05  HDR-YR        PIC XX.
  8494. 081300     05  FILLER         PIC X(09)     VALUE SPACES.
  8495. 081400     05  FILLER         PIC X(48)     VALUE
  8496. 081500         "USDI- BUR OF LAND MGT  ECOLOGICAL SITE INVENTORY".
  8497. 081600     05  FILLER         PIC X(31)     VALUE SPACES.
  8498. 081700     05  FILLER         PIC X(5)      VALUE "PAGE:".
  8499. 081800     05  HDR-PG         PIC ZZZZZ9.
  8500. 081900 01  HDR-2.
  8501. 082000     05  FILLER        PIC X(17)     VALUE SPACES.
  8502. 082100     05  FILLER        PIC X(8)      VALUE "STATE:  ".
  8503. 082200     05  HDR-ST-NM     PIC X(10).
  8504. 082300     05  FILLER        PIC X(16)     VALUE SPACES.
  8505. 082400     05  FILLER        PIC X(7)      VALUE "DIST:  ".
  8506. 082500     05  HDR-DIST-NM         PIC X(15).
  8507. 082600     05  FILLER        PIC X(15)     VALUE SPACES.
  8508. 082700     05  RMK-HDR-2  PIC X(22)  VALUE SPACE.
  8509. 082800     05  FILLER        PIC X(17)     VALUE SPACES.
  8510. 082900 01  HDR-3    PIC X(132).
  8511. 083000 01  HDR-4    PIC X(132).
  8512. 083100 01  VU-HDR-REC1.
  8513. 083200     03  FILLER   PIC X(10)       VALUE SPACE.
  8514. 083300     03  FILLER   PIC X(7)        VALUE "REC TYP".
  8515. 083400     03  FILLER   PIC X(12)       VALUE SPACE.
  8516. 083500     03  FILLER   PIC X(2)        VALUE "ST".
  8517. 083600     03  FILLER   PIC X(12)       VALUE SPACE.
  8518. 083700     03  FILLER   PIC X(4)        VALUE "DIST".
  8519. 083800     03  FILLER   PIC X(12)       VALUE SPACE.
  8520. 083900     03  FILLER   PIC X(2)        VALUE "RA".
  8521. 084000     03  FILLER   PIC X(14)       VALUE SPACE.
  8522. 084100     03  FILLER   PIC X(3)        VALUE "PLU".
  8523. 084200     03  FILLER   PIC X(14)       VALUE SPACE.
  8524. 084300     03  FILLER   PIC X(4)        VALUE "DATE".
  8525. 084400     03  FILLER   PIC X(12)       VALUE SPACE.
  8526. 084500     03  FILLER   PIC X(4)        VALUE "ACTN".
  8527. 084600     03  FILLER   PIC X(6)       VALUE SPACE.
  8528. 084700     03  FILLER   PIC X(7)        VALUE "PUF/DPV".
  8529. 084800     03  FILLER   PIC X(7)       VALUE SPACE.
  8530. 084900 01  VU-HDR-REC2.
  8531. 085000     03  FILLER   PIC X(10)       VALUE SPACE.
  8532. 085100     03  FILLER   PIC X(7)        VALUE "  1-4  ".
  8533. 085200     03  FILLER   PIC X(11)       VALUE SPACE.
  8534. 085300     03  FILLER   PIC X(3)        VALUE "5-6".
  8535. 085400     03  FILLER   PIC X(13)       VALUE SPACE.
  8536. 085500     03  FILLER   PIC X(3)        VALUE "7-8".
  8537. 085600     03  FILLER   PIC X(11)       VALUE SPACE.
  8538. 085700     03  FILLER   PIC X(4)        VALUE "9-10".
  8539. 085800     03  FILLER   PIC X(12)       VALUE SPACE.
  8540. 085900     03  FILLER   PIC X(5)        VALUE "11-12".
  8541. 086000     03  FILLER   PIC X(12)       VALUE SPACE.
  8542. 086100     03  FILLER   PIC X(5)        VALUE "13-18".
  8543. 086200     03  FILLER   PIC X(12)       VALUE SPACE.
  8544. 086300     03  FILLER   PIC X(4)        VALUE " 19 ".
  8545. 086400     03  FILLER   PIC X(6)       VALUE SPACE.
  8546. 086500     03  FILLER   PIC X(7)        VALUE "  20   ".
  8547. 086600     03  FILLER   PIC X(7)       VALUE SPACE.
  8548. 086700 01  VU-HDR-REC3.
  8549. 086800     03  FILLER   PIC X(10)       VALUE SPACE.
  8550. 086900     03  FILLER   PIC X(7)        VALUE "  XXXX ".
  8551. 087000     03  FILLER   PIC X(11)       VALUE SPACE.
  8552. 087100     03  FILLER   PIC X(3)        VALUE " XX".
  8553. 087200     03  FILLER   PIC X(13)       VALUE SPACE.
  8554. 087300     03  FILLER   PIC X(3)        VALUE " XX".
  8555. 087400     03  FILLER   PIC X(11)       VALUE SPACE.
  8556. 087500     03  FILLER   PIC X(4)        VALUE " XX ".
  8557. 087600     03  FILLER   PIC X(12)       VALUE SPACE.
  8558. 087700     03  FILLER   PIC X(5)        VALUE "  XX ".
  8559. 087800     03  FILLER   PIC X(12)       VALUE SPACE.
  8560. 087900     03  FILLER   PIC X(6)        VALUE "XXXXXX".
  8561. 088000     03  FILLER   PIC X(12)       VALUE SPACE.
  8562. 088100     03  FILLER   PIC X(4)        VALUE " X  ".
  8563. 088200     03  FILLER   PIC X(6)       VALUE SPACE.
  8564. 088300     03  FILLER   PIC X(7)        VALUE "  X    ".
  8565. 088400     03  FILLER   PIC X(7)       VALUE SPACE.
  8566. 088500 01  VF-HDR-REC1.
  8567. 088600     03  FILLER   PIC X(15)       VALUE SPACE.
  8568. 088700     03  FILLER   PIC X(7)        VALUE "REC TYP".
  8569. 088800     03  FILLER   PIC X(12)       VALUE SPACE.
  8570. 088900     03  FILLER   PIC X(2)        VALUE "ST".
  8571. 089000     03  FILLER   PIC X(12)       VALUE SPACE.
  8572. 089100     03  FILLER   PIC X(4)        VALUE "DIST".
  8573. 089200     03  FILLER   PIC X(12)       VALUE SPACE.
  8574. 089300     03  FILLER   PIC X(4)        VALUE "DATE".
  8575. 089400     03  FILLER   PIC X(12)       VALUE SPACE.
  8576. 089500     03  FILLER   PIC X(4)        VALUE "ACTN".
  8577. 089600     03  FILLER   PIC X(50)       VALUE SPACE.
  8578. 089700 01  VF-HDR-REC2.
  8579. 089800     03  FILLER   PIC X(15)       VALUE SPACE.
  8580. 089900     03  FILLER   PIC X(7)        VALUE "  1-4  ".
  8581. 090000     03  FILLER   PIC X(11)       VALUE SPACE.
  8582. 090100     03  FILLER   PIC X(3)        VALUE "5-6".
  8583. 090200     03  FILLER   PIC X(13)       VALUE SPACE.
  8584. 090300     03  FILLER   PIC X(3)        VALUE "7-8".
  8585. 090400     03  FILLER   PIC X(11)       VALUE SPACE.
  8586. 090500     03  FILLER   PIC X(5)        VALUE "13-18".
  8587. 090600     03  FILLER   PIC X(12)       VALUE SPACE.
  8588. 090700     03  FILLER   PIC X(4)        VALUE " 19 ".
  8589. 090800     03  FILLER   PIC X(50)       VALUE SPACE.
  8590. 090900 01  VF-HDR-REC3.
  8591. 091000     03  FILLER   PIC X(15)       VALUE SPACE.
  8592. 091100     03  FILLER   PIC X(7)        VALUE "  XXXX ".
  8593. 091200     03  FILLER   PIC X(11)       VALUE SPACE.
  8594. 091300     03  FILLER   PIC X(3)        VALUE " XX".
  8595. 091400     03  FILLER   PIC X(13)       VALUE SPACE.
  8596. 091500     03  FILLER   PIC X(3)        VALUE " XX".
  8597. 091600     03  FILLER   PIC X(11)       VALUE SPACE.
  8598. 091700     03  FILLER   PIC X(6)        VALUE "XXXXXX".
  8599. 091800     03  FILLER   PIC X(11)       VALUE SPACE.
  8600. 091900     03  FILLER   PIC X(4)        VALUE "  X ".
  8601. 092000     03  FILLER   PIC X(48)       VALUE SPACE.
  8602. 092100 01  V6P-HDR-REC1.
  8603. 092200     03  FILLER   PIC X(15)       VALUE SPACE.
  8604. 092300     03  FILLER   PIC X(7)        VALUE "REC TYP".
  8605. 092400     03  FILLER   PIC X(12)       VALUE SPACE.
  8606. 092500     03  FILLER   PIC X(2)        VALUE "ST".
  8607. 092600     03  FILLER   PIC X(12)       VALUE SPACE.
  8608. 092700     03  FILLER   PIC X(4)        VALUE "DIST".
  8609. 092800     03  FILLER   PIC X(12)       VALUE SPACE.
  8610. 092900     03  FILLER   PIC X(2)        VALUE "RA".
  8611. 093000     03  FILLER   PIC X(14)       VALUE SPACE.
  8612. 093100     03  FILLER   PIC X(3)        VALUE "PLU".
  8613. 093200     03  FILLER   PIC X(14)       VALUE SPACE.
  8614. 093300     03  FILLER   PIC X(4)        VALUE "DATE".
  8615. 093400     03  FILLER   PIC X(12)       VALUE SPACE.
  8616. 093500     03  FILLER   PIC X(4)        VALUE "ACTN".
  8617. 093600     03  FILLER   PIC X(15)       VALUE SPACE.
  8618. 093700 01  V6P-HDR-REC2.
  8619. 093800     03  FILLER   PIC X(15)       VALUE SPACE.
  8620. 093900     03  FILLER   PIC X(7)        VALUE "  1-4  ".
  8621. 094000     03  FILLER   PIC X(11)       VALUE SPACE.
  8622. 094100     03  FILLER   PIC X(3)        VALUE "5-6".
  8623. 094200     03  FILLER   PIC X(13)       VALUE SPACE.
  8624. 094300     03  FILLER   PIC X(3)        VALUE "7-8".
  8625. 094400     03  FILLER   PIC X(11)       VALUE SPACE.
  8626. 094500     03  FILLER   PIC X(4)        VALUE "9-10".
  8627. 094600     03  FILLER   PIC X(12)       VALUE SPACE.
  8628. 094700     03  FILLER   PIC X(5)        VALUE "11-12".
  8629. 094800     03  FILLER   PIC X(12)       VALUE SPACE.
  8630. 094900     03  FILLER   PIC X(5)        VALUE "13-18".
  8631. 095000     03  FILLER   PIC X(12)       VALUE SPACE.
  8632. 095100     03  FILLER   PIC X(4)        VALUE " 19 ".
  8633. 095200     03  FILLER   PIC X(20)       VALUE SPACE.
  8634. 095300 01  V6P-HDR-REC3.
  8635. 095400     03  FILLER   PIC X(15)       VALUE SPACE.
  8636. 095500     03  FILLER   PIC X(7)        VALUE "  XXXX ".
  8637. 095600     03  FILLER   PIC X(11)       VALUE SPACE.
  8638. 095700     03  FILLER   PIC X(3)        VALUE " XX".
  8639. 095800     03  FILLER   PIC X(13)       VALUE SPACE.
  8640. 095900     03  FILLER   PIC X(3)        VALUE " XX".
  8641. 096000     03  FILLER   PIC X(11)       VALUE SPACE.
  8642. 096100     03  FILLER   PIC X(5)        VALUE " XX  ".
  8643. 096200     03  FILLER   PIC X(12)       VALUE SPACE.
  8644. 096300     03  FILLER   PIC X(5)        VALUE " XX  ".
  8645. 096400     03  FILLER   PIC X(11)       VALUE SPACE.
  8646. 096500     03  FILLER   PIC X(6)        VALUE "XXXXXX".
  8647. 096600     03  FILLER   PIC X(11)       VALUE SPACE.
  8648. 096700     03  FILLER   PIC X(4)        VALUE "  X ".
  8649. 096800     03  FILLER   PIC X(20)       VALUE SPACE.
  8650. 096900***********************************************************
  8651. 097000**********************************************************
  8652. 097100***********************************************************
  8653. 097200 01  VF-HDR-REC4.
  8654. 097300     03  FILLER  PIC X(6)  VALUE SPACE.
  8655. 097400     03  FILLER  PIC X(7)  VALUE "LIN NUM".
  8656. 097500     03  FILLER  PIC X(4)  VALUE SPACE.
  8657. 097600     03  FILLER  PIC X(7)  VALUE "ANML SP".
  8658. 097700     03  FILLER  PIC XXXX  VALUE SPACE.
  8659. 097800     03  FILLER  PIC X(8)  VALUE "MON FORG".
  8660. 097900     03  FILLER  PIC XXXX  VALUE SPACE.
  8661. 098000     03  FILLER  PIC X(14)  VALUE "HT-CLASS AVAIL".
  8662. 098100     03  FILLER  PIC X(78)  VALUE SPACE.
  8663. 098200 01  VF-HDR-REC5.
  8664. 098300     03  FILLER  PIC X(6)  VALUE SPACE.
  8665. 098400     03  FILLER  PIC X(7)  VALUE " 20-23 ".
  8666. 098500     03  FILLER  PIC X(4)  VALUE SPACE.
  8667. 098600     03  FILLER  PIC X(7)  VALUE " 24-25 ".
  8668. 098700     03  FILLER  PIC XXXX  VALUE SPACE.
  8669. 098800     03  FILLER  PIC X(8)  VALUE "  26-29 ".
  8670. 098900     03  FILLER  PIC XXXX  VALUE SPACE.
  8671. 099000     03  FILLER  PIC X(14)  VALUE "       30    ".
  8672. 099100     03  FILLER  PIC X(78)  VALUE SPACE.
  8673. 099200 01  VF-HDR-REC6.
  8674. 099300     03  FILLER  PIC X(6)  VALUE SPACE.
  8675. 099400     03  FILLER  PIC X(7)  VALUE "  XXXX ".
  8676. 099500     03  FILLER  PIC X(4)  VALUE SPACE.
  8677. 099600     03  FILLER  PIC X(7)  VALUE "   XX  ".
  8678. 099700     03  FILLER  PIC XXXX  VALUE SPACE.
  8679. 099800     03  FILLER  PIC X(8)  VALUE "  XXXX  ".
  8680. 099900     03  FILLER  PIC XXXX  VALUE SPACE.
  8681. 100000     03  FILLER  PIC X(14)  VALUE "        X    ".
  8682. 100100     03  FILLER  PIC X(78)  VALUE SPACE.
  8683. 100200 01  VU-HDR-REC4.
  8684. 100300     03  FILLER  PIC X(6)  VALUE SPACE.
  8685. 100400     03  FILLER  PIC X(7)  VALUE "LIN NUM".
  8686. 100500     03  FILLER  PIC X(2)  VALUE SPACE.
  8687. 100600     03  FILLER  PIC X(7)  VALUE " PLANT ".
  8688. 100700     03  FILLER  PIC X(2)  VALUE SPACE.
  8689. 100800     03  FILLER  PIC X(6)  VALUE "SPRING".
  8690. 100900     03  FILLER  PIC X(3)  VALUE SPACE.
  8691. 101000     03  FILLER  PIC X(6)  VALUE "SUMMER".
  8692. 101100     03  FILLER  PIC X(2)  VALUE SPACE.
  8693. 101200     03  FILLER  PIC X(5)  VALUE " FALL".
  8694. 101300     03  FILLER  PIC X(2)  VALUE SPACE.
  8695. 101400     03  FILLER  PIC X(6)  VALUE "WINTER".
  8696. 101500     03  FILLER  PIC X(2)  VALUE SPACE.
  8697. 101600     03  FILLER  PIC X(7)  VALUE "YR LONG".
  8698. 101700     03  FILLER  PIC X(3)  VALUE SPACE.
  8699. 101800     03  FILLER  PIC X(7)  VALUE "ANML SP".
  8700. 101900     03  FILLER  PIC X(3)  VALUE SPACE.
  8701. 102000     03  FILLER  PIC X(6)  VALUE "SPRING".
  8702. 102100     03  FILLER  PIC X(3)  VALUE SPACE.
  8703. 102200     03  FILLER  PIC X(6)  VALUE "SUMMER".
  8704. 102300     03  FILLER  PIC X(4)  VALUE SPACE.
  8705. 102400     03  FILLER  PIC X(5)  VALUE " FALL".
  8706. 102500     03  FILLER  PIC X(3)  VALUE SPACE.
  8707. 102600     03  FILLER  PIC X(6)  VALUE "WINTER".
  8708. 102700     03  FILLER  PIC X(3)  VALUE SPACE.
  8709. 102800     03  FILLER  PIC X(7)  VALUE "YR LONG".
  8710. 102900     03  FILLER  PIC X(7)  VALUE SPACE.
  8711. 103000 01  VU-HDR-REC5.
  8712. 103100     03  FILLER  PIC X(6)  VALUE SPACE.
  8713. 103200     03  FILLER  PIC X(7)  VALUE " 21-24 ".
  8714. 103300     03  FILLER  PIC X(2)  VALUE SPACE.
  8715. 103400     03  FILLER  PIC X(7)  VALUE " 25-31 ".
  8716. 103500     03  FILLER  PIC X(2)  VALUE SPACE.
  8717. 103600     03  FILLER  PIC X(6)  VALUE " 32-34".
  8718. 103700     03  FILLER  PIC X(3)  VALUE SPACE.
  8719. 103800     03  FILLER  PIC X(6)  VALUE "35-37 ".
  8720. 103900     03  FILLER  PIC X(2)  VALUE SPACE.
  8721. 104000     03  FILLER  PIC X(5)  VALUE "38-40".
  8722. 104100     03  FILLER  PIC X(2)  VALUE SPACE.
  8723. 104200     03  FILLER  PIC X(6)  VALUE " 41-43".
  8724. 104300     03  FILLER  PIC X(2)  VALUE SPACE.
  8725. 104400     03  FILLER  PIC X(7)  VALUE " 44-46 ".
  8726. 104500     03  FILLER  PIC X(3)  VALUE SPACE.
  8727. 104600     03  FILLER  PIC X(7)  VALUE " 47-48 ".
  8728. 104700     03  FILLER  PIC X(3)  VALUE SPACE.
  8729. 104800     03  FILLER  PIC X(6)  VALUE " 49-50".
  8730. 104900     03  FILLER  PIC X(3)  VALUE SPACE.
  8731. 105000     03  FILLER  PIC X(6)  VALUE " 51-52".
  8732. 105100     03  FILLER  PIC X(4)  VALUE SPACE.
  8733. 105200     03  FILLER  PIC X(5)  VALUE "53-54".
  8734. 105300     03  FILLER  PIC X(3)  VALUE SPACE.
  8735. 105400     03  FILLER  PIC X(6)  VALUE " 55-56".
  8736. 105500     03  FILLER  PIC X(3)  VALUE SPACE.
  8737. 105600     03  FILLER  PIC X(7)  VALUE " 57-58 ".
  8738. 105700     03  FILLER  PIC X(7)  VALUE SPACE.
  8739. 105800***********************************************************
  8740. 105900 01  VU-HDR-REC6.
  8741. 106000     03  FILLER  PIC X(6)  VALUE SPACE.
  8742. 106100     03  FILLER  PIC X(7)  VALUE "  XXXX ".
  8743. 106200     03  FILLER  PIC X(2)  VALUE SPACE.
  8744. 106300     03  FILLER  PIC X(7)  VALUE "XXXXXXX".
  8745. 106400     03  FILLER  PIC X(2)  VALUE SPACE.
  8746. 106500     03  FILLER  PIC X(6)  VALUE "  XXX ".
  8747. 106600     03  FILLER  PIC X(3)  VALUE SPACE.
  8748. 106700     03  FILLER  PIC X(6)  VALUE " XXX  ".
  8749. 106800     03  FILLER  PIC X(2)  VALUE SPACE.
  8750. 106900     03  FILLER  PIC X(5)  VALUE " XXX ".
  8751. 107000     03  FILLER  PIC X(2)  VALUE SPACE.
  8752. 107100     03  FILLER  PIC X(6)  VALUE "  XXX ".
  8753. 107200     03  FILLER  PIC X(2)  VALUE SPACE.
  8754. 107300     03  FILLER  PIC X(7)  VALUE "  XXX  ".
  8755. 107400     03  FILLER  PIC X(3)  VALUE SPACE.
  8756. 107500     03  FILLER  PIC X(7)  VALUE "   XX  ".
  8757. 107600     03  FILLER  PIC X(3)  VALUE SPACE.
  8758. 107700     03  FILLER  PIC X(6)  VALUE "  XX  ".
  8759. 107800     03  FILLER  PIC X(3)  VALUE SPACE.
  8760. 107900     03  FILLER  PIC X(6)  VALUE "  XX  ".
  8761. 108000     03  FILLER  PIC X(3)  VALUE SPACE.
  8762. 108100     03  FILLER  PIC X(6)  VALUE "  XX  ".
  8763. 108200     03  FILLER  PIC X(3)  VALUE SPACE.
  8764. 108300     03  FILLER  PIC X(6)  VALUE "  XX  ".
  8765. 108400     03  FILLER  PIC X(3)  VALUE SPACE.
  8766. 108500     03  FILLER  PIC X(7)  VALUE "  XX  ".
  8767. 108600     03  FILLER  PIC X(3)  VALUE SPACE.
  8768. 108700     03  FILLER  PIC X(14)  VALUE SPACE.
  8769. 108800***********************************************************
  8770. 108900 01  V6-HDR-REC4.
  8771. 109000     03  FILLER  PIC X(3)  VALUE SPACE.
  8772. 109100     03  FILLER  PIC X(7)  VALUE "LIN NUM".
  8773. 109200     03  FILLER  PIC X(2)  VALUE SPACE.
  8774. 109300     03  FILLER  PIC X(7)  VALUE " PLANT ".
  8775. 109400     03  FILLER  PIC X(2)  VALUE SPACE.
  8776. 109500     03  FILLER  PIC X(4)  VALUE "PHNO".
  8777. 109600     03  FILLER  PIC X(3)  VALUE SPACE.
  8778. 109700     03  FILLER  PIC X(7)  VALUE "GRN WGT".
  8779. 109800     03  FILLER  PIC X(3)  VALUE SPACE.
  8780. 109900     03  FILLER  PIC X(8)  VALUE "%DRY WGT".
  8781. 110000     03  FILLER  PIC X(3)  VALUE SPACE.
  8782. 110100     03  FILLER  PIC X(7)  VALUE "DRY WGT".
  8783. 110200     03  FILLER  PIC X(3)  VALUE SPACE.
  8784. 110300     03  FILLER  PIC X(10)  VALUE "MIN BA-DIA".
  8785. 110400     03  FILLER  PIC X(3)  VALUE SPACE.
  8786. 110500     03  FILLER  PIC X(10)  VALUE "MAX BA-DIA".
  8787. 110600     03  FILLER  PIC X(3)  VALUE SPACE.
  8788. 110700     03  FILLER  PIC X(11)  VALUE "MIN CRN-DIA".
  8789. 110800     03  FILLER  PIC X(3)  VALUE SPACE.
  8790. 110900     03  FILLER  PIC X(11)  VALUE "MAX CRN-DIA".
  8791. 111000     03  FILLER  PIC X(2)  VALUE SPACE.
  8792. 111100     03  FILLER  PIC X(5)  VALUE " HGT ".
  8793. 111200     03  FILLER  PIC X(2)  VALUE SPACE.
  8794. 111300     03  FILLER  PIC X(13)  VALUE "AVG LDR   CNT".
  8795. 111400 01  V6-HDR-REC5.
  8796. 111500     03  FILLER  PIC X(3)  VALUE SPACE.
  8797. 111600     03  FILLER  PIC X(7)  VALUE " 20-23 ".
  8798. 111700     03  FILLER  PIC X(2)  VALUE SPACE.
  8799. 111800     03  FILLER  PIC X(7)  VALUE " 24-30 ".
  8800. 111900     03  FILLER  PIC X(2)  VALUE SPACE.
  8801. 112000     03  FILLER  PIC X(4)  VALUE " 31 ".
  8802. 112100     03  FILLER  PIC X(3)  VALUE SPACE.
  8803. 112200     03  FILLER  PIC X(7)  VALUE " 32-35 ".
  8804. 112300     03  FILLER  PIC X(3)  VALUE SPACE.
  8805. 112400     03  FILLER  PIC X(8)  VALUE "  36-38 ".
  8806. 112500     03  FILLER  PIC X(3)  VALUE SPACE.
  8807. 112600     03  FILLER  PIC X(7)  VALUE " 39-42 ".
  8808. 112700     03  FILLER  PIC X(3)  VALUE SPACE.
  8809. 112800     03  FILLER  PIC X(10)  VALUE "   43-46  ".
  8810. 112900     03  FILLER  PIC X(3)  VALUE SPACE.
  8811. 113000     03  FILLER  PIC X(10)  VALUE "  47-50   ".
  8812. 113100     03  FILLER  PIC X(3)  VALUE SPACE.
  8813. 113200     03  FILLER  PIC X(11)  VALUE "   51-53   ".
  8814. 113300     03  FILLER  PIC X(3)  VALUE SPACE.
  8815. 113400     03  FILLER  PIC X(11)  VALUE "   54-56   ".
  8816. 113500     03  FILLER  PIC X(2)  VALUE SPACE.
  8817. 113600     03  FILLER  PIC X(5)  VALUE "57-60".
  8818. 113700     03  FILLER  PIC X(2)  VALUE SPACE.
  8819. 113800     03  FILLER  PIC X(13)  VALUE "61-63   65-66".
  8820. 113900 01  V6-HDR-REC6.
  8821. 114000     03  FILLER  PIC X(3)  VALUE SPACE.
  8822. 114100     03  FILLER  PIC X(7)  VALUE "  XXXX ".
  8823. 114200     03  FILLER  PIC X(2)  VALUE SPACE.
  8824. 114300     03  FILLER  PIC X(7)  VALUE "XXXXXXX".
  8825. 114400     03  FILLER  PIC X(2)  VALUE SPACE.
  8826. 114500     03  FILLER  PIC X(4)  VALUE "  X ".
  8827. 114600     03  FILLER  PIC X(3)  VALUE SPACE.
  8828. 114700     03  FILLER  PIC X(7)  VALUE "  XXXX ".
  8829. 114800     03  FILLER  PIC X(3)  VALUE SPACE.
  8830. 114900     03  FILLER  PIC X(8)  VALUE "   XXX ".
  8831. 115000     03  FILLER  PIC X(3)  VALUE SPACE.
  8832. 115100     03  FILLER  PIC X(7)  VALUE "  XXXX ".
  8833. 115200     03  FILLER  PIC X(3)  VALUE SPACE.
  8834. 115300     03  FILLER  PIC X(10)  VALUE "   XX XX  ".
  8835. 115400     03  FILLER  PIC X(3)  VALUE SPACE.
  8836. 115500     03  FILLER  PIC X(10)  VALUE "  XX XX   ".
  8837. 115600     03  FILLER  PIC X(4)  VALUE SPACE.
  8838. 115700     03  FILLER  PIC X(10)  VALUE "   XX X   ".
  8839. 115800     03  FILLER  PIC X(4)  VALUE SPACE.
  8840. 115900     03  FILLER  PIC X(10)  VALUE "   XX X   ".
  8841. 116000     03  FILLER  PIC X(2)  VALUE SPACE.
  8842. 116100     03  FILLER  PIC X(5)  VALUE "XXX X".
  8843. 116200     03  FILLER  PIC X(2)  VALUE SPACE.
  8844. 116300     03  FILLER  PIC X(13)  VALUE "     XX X  XX".
  8845. 116400 01  VP-HDR-REC4.
  8846. 116500     03  FILLER  PIC X(6)  VALUE SPACE.
  8847. 116600     03  FILLER  PIC X(7)  VALUE "LIN NUM".
  8848. 116700     03  FILLER  PIC X(7)  VALUE SPACE.
  8849. 116800     03  FILLER  PIC X(7)  VALUE " PLANT ".
  8850. 116900     03  FILLER  PIC X(4)  VALUE SPACE.
  8851. 117000     03  FILLER  PIC X(8)  VALUE "PHNO-1 %".
  8852. 117100     03  FILLER  PIC X(4)  VALUE SPACE.
  8853. 117200     03  FILLER  PIC X(8)  VALUE "PHNO-2 %".
  8854. 117300     03  FILLER  PIC X(4)  VALUE SPACE.
  8855. 117400     03  FILLER  PIC X(8)  VALUE "PHNO-3 %".
  8856. 117500     03  FILLER  PIC X(4)  VALUE SPACE.
  8857. 117600     03  FILLER  PIC X(8)  VALUE "PHNO-4 %".
  8858. 117700     03  FILLER  PIC X(4)  VALUE SPACE.
  8859. 117800     03  FILLER  PIC X(8)  VALUE "PHNO-5 %".
  8860. 117900     03  FILLER  PIC X(4)  VALUE SPACE.
  8861. 118000     03  FILLER  PIC X(8)  VALUE "PHNO-6 %".
  8862. 118100     03  FILLER  PIC X(4)  VALUE SPACE.
  8863. 118200     03  FILLER  PIC X(8)  VALUE "PHNO-7 %".
  8864. 118300     03  FILLER  PIC X(4)  VALUE SPACE.
  8865. 118400     03  FILLER  PIC X(8)  VALUE "PHNO-8 %".
  8866. 118500     03  FILLER  PIC X(9)  VALUE SPACE.
  8867. 118600 01  VP-HDR-REC5.
  8868. 118700     03  FILLER  PIC X(6)  VALUE SPACE.
  8869. 118800     03  FILLER  PIC X(7)  VALUE " 20-23 ".
  8870. 118900     03  FILLER  PIC X(7)  VALUE SPACE.
  8871. 119000     03  FILLER  PIC X(7)  VALUE " 24-30 ".
  8872. 119100     03  FILLER  PIC X(4)  VALUE SPACE.
  8873. 119200     03  FILLER  PIC X(8)  VALUE "  31-34 ".
  8874. 119300     03  FILLER  PIC X(4)  VALUE SPACE.
  8875. 119400     03  FILLER  PIC X(8)  VALUE "  35-38 ".
  8876. 119500     03  FILLER  PIC X(4)  VALUE SPACE.
  8877. 119600     03  FILLER  PIC X(8)  VALUE "  39-42 ".
  8878. 119700     03  FILLER  PIC X(4)  VALUE SPACE.
  8879. 119800     03  FILLER  PIC X(8)  VALUE "  43-46 ".
  8880. 119900     03  FILLER  PIC X(4)  VALUE SPACE.
  8881. 120000     03  FILLER  PIC X(8)  VALUE "  47-50 ".
  8882. 120100     03  FILLER  PIC X(4)  VALUE SPACE.
  8883. 120200     03  FILLER  PIC X(8)  VALUE "  51-54 ".
  8884. 120300     03  FILLER  PIC X(4)  VALUE SPACE.
  8885. 120400     03  FILLER  PIC X(8)  VALUE "  55-58 ".
  8886. 120500     03  FILLER  PIC X(4)  VALUE SPACE.
  8887. 120600     03  FILLER  PIC X(8)  VALUE "  59-62 ".
  8888. 120700     03  FILLER  PIC X(9)  VALUE SPACE.
  8889. 120800 01  VP-HDR-REC6.
  8890. 120900     03  FILLER  PIC X(6)  VALUE SPACE.
  8891. 121000     03  FILLER  PIC X(7)  VALUE "  XXXX ".
  8892. 121100     03  FILLER  PIC X(7)  VALUE SPACE.
  8893. 121200     03  FILLER  PIC X(7)  VALUE "XXXXXXX".
  8894. 121300     03  FILLER  PIC X(4)  VALUE SPACE.
  8895. 121400     03  FILLER  PIC X(8)  VALUE "  XX XX ".
  8896. 121500     03  FILLER  PIC X(4)  VALUE SPACE.
  8897. 121600     03  FILLER  PIC X(8)  VALUE "  XX XX ".
  8898. 121700     03  FILLER  PIC X(4)  VALUE SPACE.
  8899. 121800     03  FILLER  PIC X(8)  VALUE "  XX XX ".
  8900. 121900     03  FILLER  PIC X(4)  VALUE SPACE.
  8901. 122000     03  FILLER  PIC X(8)  VALUE "  XX XX ".
  8902. 122100     03  FILLER  PIC X(4)  VALUE SPACE.
  8903. 122200     03  FILLER  PIC X(8)  VALUE "  XX XX ".
  8904. 122300     03  FILLER  PIC X(4)  VALUE SPACE.
  8905. 122400     03  FILLER  PIC X(8)  VALUE "  XX XX ".
  8906. 122500     03  FILLER  PIC X(4)  VALUE SPACE.
  8907. 122600     03  FILLER  PIC X(8)  VALUE "  XX XX ".
  8908. 122700     03  FILLER  PIC X(4)  VALUE SPACE.
  8909. 122800     03  FILLER  PIC X(8)  VALUE "  XX XX ".
  8910. 122900     03  FILLER  PIC X(9)  VALUE SPACE.
  8911. 123000***********************************************************
  8912. 123100 01  MSG-1-V6P.
  8913. 123200     03  FILLER  PIC X(24)  VALUE SPACE.
  8914. 123300     03  FILLER  PIC X(26)  VALUE "IF ERROR CORRECTION IS IN ".
  8915. 123400     03  FILLER  PIC X(26)  VALUE "COMMON DATA (1-12), KEY AL".
  8916. 123500     03  FILLER  PIC X(26)  VALUE "L RECORDS WITH SAME COMMON".
  8917. 123600     03  FILLER  PIC X(26)  VALUE " DATA.                    ".
  8918. 123700     03  FILLER  PIC XXXX  VALUE SPACE.
  8919. 123800 01  MSG-2-V6.
  8920. 123900     03  FILLER  PIC X(24)  VALUE SPACE.
  8921. 124000     03  FILLER  PIC X(26)  VALUE "IF ERROR CORRECTION IS IN ".
  8922. 124100     03  FILLER  PIC X(26)  VALUE "FIELD POSITIONS (24-63), K".
  8923. 124200     03  FILLER  PIC X(26)  VALUE "EY (1-23) AND RED CORRECTE".
  8924. 124300     03  FILLER  PIC X(26)  VALUE "D FIELDS.                 ".
  8925. 124400     03  FILLER  PIC XXXX  VALUE SPACE.
  8926. 124500 01  MSG-2-VP.
  8927. 124600     03  FILLER  PIC X(24)  VALUE SPACE.
  8928. 124700     03  FILLER  PIC X(26)  VALUE "IF ERROR CORRECTION IS IN ".
  8929. 124800     03  FILLER  PIC X(26)  VALUE "FIELD POSITIONS (24-62), K".
  8930. 124900     03  FILLER  PIC X(26)  VALUE "EY (1-23) AND RED CORRECTE".
  8931. 125000     03  FILLER  PIC X(26)  VALUE "D FIELDS.                 ".
  8932. 125100     03  FILLER  PIC XXXX  VALUE SPACE.
  8933. 125200 01  MSG-1-VU.
  8934. 125300     03  FILLER  PIC X(24)  VALUE SPACE.
  8935. 125400     03  FILLER  PIC X(26)  VALUE "IF ERROR CORRECTION IS IN ".
  8936. 125500     03  FILLER  PIC X(26)  VALUE "COMMON DATA (1-12 OR 20), ".
  8937. 125600     03  FILLER  PIC X(26)  VALUE "KEY ALL RECORDS WITH SAME ".
  8938. 125700     03  FILLER  PIC X(26)  VALUE "COMMON DATA.              ".
  8939. 125800     03  FILLER  PIC XXXX  VALUE SPACE.
  8940. 125900 01  MSG-2-VU.
  8941. 126000     03  FILLER  PIC X(24)  VALUE SPACE.
  8942. 126100     03  FILLER  PIC X(26)  VALUE "IF ERROR CORRECTION IS IN ".
  8943. 126200     03  FILLER  PIC X(26)  VALUE "FIELD POSITIONS (25-58), K".
  8944. 126300     03  FILLER  PIC X(26)  VALUE "EY (1-24) AND RED CORRECTE".
  8945. 126400     03  FILLER  PIC X(26)  VALUE "D FIELDS.                 ".
  8946. 126500     03  FILLER  PIC XXXX  VALUE SPACE.
  8947. 126600 01  MSG-1-VF.
  8948. 126700     03  FILLER  PIC X(24)  VALUE SPACE.
  8949. 126800     03  FILLER  PIC X(26)  VALUE "IF ERROR CORRECTION IS IN ".
  8950. 126900     03  FILLER  PIC X(26)  VALUE "COMMON DATA (1-8),  KEY AL".
  8951. 127000     03  FILLER  PIC X(26)  VALUE "L RECORDS WITH SAME COMMON".
  8952. 127100     03  FILLER  PIC X(26)  VALUE " DATA.                    ".
  8953. 127200     03  FILLER  PIC XXXX  VALUE SPACE.
  8954. 127300 01  MSG-2-VF.
  8955. 127400     03  FILLER  PIC X(24)  VALUE SPACE.
  8956. 127500     03  FILLER  PIC X(26)  VALUE "IF ERROR CORRECTION IS IN ".
  8957. 127600     03  FILLER  PIC X(26)  VALUE "FIELD POSITIONS (24-30), K".
  8958. 127700     03  FILLER  PIC X(26)  VALUE "EY (1-23) AND RED CORRECTE".
  8959. 127800     03  FILLER  PIC X(26)  VALUE "D FIELDS.                 ".
  8960. 127900     03  FILLER  PIC XXXX  VALUE SPACE.
  8961. 128000***********************************************************
  8962. 128100***********************************************************
  8963. 128200 01 AST-HLD.
  8964. 128300     03  ST-HLD-AST   PIC XX.
  8965. 128400     03  DIST-HLD-AST   PIC XX.
  8966. 128500     03  RA-HLD-AST     PIC XX.
  8967. 128600     03  PLU-HLD-AST    PIC XX.
  8968. 128700     03  ACTN-HLD-AST    PIC XX.
  8969. 128800 01  LAST-HLD.
  8970. 128900     03  LAST-PRINT.
  8971. 129000         05  REC-TYP-LP   PIC XXXX.
  8972. 129100         05  SDRP-LP.
  8973. 129200             07  SDR-LP.
  8974. 129300                 09  SD-LP.
  8975. 129400                     11  ST-LP       PIC XX.
  8976. 129500                     11  DIST-LP       PIC XX.
  8977. 129600                 09  RA-LP       PIC XX.
  8978. 129700             07  PLU-LP        PIC XX.
  8979. 129800 COPY DBSTATUS OF TPCOBOLIB.
  8980. 129900 01  CNTL-HLD.
  8981. 130000     03  CUR-PRINT.
  8982. 130100         05  REC-TYP-HLD PIC XXXX.
  8983. 130200         05  SDRP-HLD.
  8984. 130300             07  SDR-HLD.
  8985. 130400                 09  SD-HLD.
  8986. 130500                     11  ST-HLD       PIC XX.
  8987. 130600                     11  DIST-HLD       PIC XX.
  8988. 130700                 09  RA-HLD       PIC XX.
  8989. 130800             07  PLU-HLD        PIC XX.
  8990. 130900     03  DATE-HLD   PIC X(6).
  8991. 131000     03  ACTN-HLD   PIC X.
  8992. 131100     03  DIET-HLD    PIC X.
  8993. 131200 01 HLD-NAMES.
  8994. 131300     03  FUNC-HLD.
  8995. 131400         05  ST-NM-HLD    PIC X(10).
  8996. 131500         05  FILLER       PIC X(14).
  8997. 131600     03  EXPL-HLD.
  8998. 131700         05  DIST-NM-HLD    PIC X(11).
  8999. 131800         05  FILLER        PIC X.
  9000. 131900         05  RA-NM-HLD     PIC X(12).
  9001. 132000         05  FILLER        PIC X.
  9002. 132100         05  PU-NM-HLD     PIC X(15).
  9003. 132200         05  FILLER        PIC X.
  9004. 132300 01  HOLD-AREA.
  9005. 132400     03  CODE-DEC-H.
  9006. 132500         05  FILLER  PIC XXXX.
  9007. 132600         05  PLANT-CD-H  PIC X(7).
  9008. 132700         05  FILLER  PIC X(24).
  9009. 132800         05  PLANT-TYP-H  PIC X.
  9010. 132900     03  DE-CD-NAM-8823-DEC-H.
  9011. 133000         05  DIST-NAM-H  PIC X(15).
  9012. 133100         05  FILLER  PIC X(9).
  9013. 133200     03  HLD-PLANT-CD    PIC X(7).
  9014. 133300     03  HLD-PLANT-TYP    PIC X.
  9015. 133400     03  HLD-ANML-CD  PIC XX.
  9016. 133500     03  PLANT-CD-PREV    PIC X(7)  VALUE SPACE.
  9017. 133600     03  PLANT-TYP-PREV    PIC X   VALUE SPACE.
  9018. 133700     03  PLANT-CD-FLG-PREV   PIC 9  VALUE ZERO.
  9019. 133800     03  PLANT-TYP-FLG-PREV   PIC 9  VALUE ZERO.
  9020. 133900     03  DAT-H.
  9021. 134000         05  YER-H  PIC XX.
  9022. 134100         05  MON-H  PIC 99.
  9023. 134200         05  DAY-H  PIC XX.
  9024. 134300     03  DATA-DATE-VP-HLD.
  9025. 134400         05  DATA-YER-VP-HLD  PIC XX.
  9026. 134500         05  DATA-MON-VP-HLD  PIC XX.
  9027. 134600         05  DATA-DAY-VP-HLD  PIC XX.
  9028. 134700     03  D-DATE-CHK.
  9029. 134800         05  D-YER-CHK  PIC XX.
  9030. 134900         05  D-MON-CHK  PIC XX.
  9031. 135000         05  D-DAY-CHK  PIC XX.
  9032. 135100     03  JDAY-H  PIC 9(5).
  9033. 135200     03  JDAY-P0-H  PIC 9(5).
  9034. 135300     03  J9-H  REDEFINES  JDAY-P0-H.
  9035. 135400         05  1ST-2C-JDAY-P0-H  PIC 99.
  9036. 135500         05  LST-3C-JDAY-P0-H  PIC 999.
  9037. 135600     03  CNTS-IGB-V6.
  9038. 135700         05  V6-I    PIC 9(5)   VALUE ZERO.
  9039. 135800         05  FILLER   PIC XX  VALUE SPACE.
  9040. 135900         05  V6-G  PIC 9(5)   VALUE ZERO.
  9041. 136000         05  FILLER   PIC XX  VALUE SPACE.
  9042. 136100         05  V6-B   PIC 9(5)   VALUE ZERO.
  9043. 136200         05  FILLER   PIC XX  VALUE SPACE.
  9044. 136300     03  CNTS-IGB-VP.
  9045. 136400         05  VP-I    PIC 9(5)   VALUE ZERO.
  9046. 136500         05  FILLER   PIC XX  VALUE SPACE.
  9047. 136600         05  VP-G  PIC 9(5)   VALUE ZERO.
  9048. 136700         05  FILLER   PIC XX  VALUE SPACE.
  9049. 136800         05  VP-B   PIC 9(5)   VALUE ZERO.
  9050. 136900         05  FILLER   PIC XX  VALUE SPACE.
  9051. 137000     03  CNTS-IGB-VF.
  9052. 137100         05  VF-I    PIC 9(5)   VALUE ZERO.
  9053. 137200         05  FILLER   PIC XX  VALUE SPACE.
  9054. 137300         05  VF-G  PIC 9(5)   VALUE ZERO.
  9055. 137400         05  FILLER   PIC XX  VALUE SPACE.
  9056. 137500         05  VF-B   PIC 9(5)   VALUE ZERO.
  9057. 137600         05  FILLER   PIC XX  VALUE SPACE.
  9058. 137700     03  CNTS-IGB-VU.
  9059. 137800         05  VU-I    PIC 9(5)   VALUE ZERO.
  9060. 137900         05  FILLER   PIC XX  VALUE SPACE.
  9061. 138000         05  VU-G  PIC 9(5)   VALUE ZERO.
  9062. 138100         05  FILLER   PIC XX  VALUE SPACE.
  9063. 138200         05  VU-B   PIC 9(5)   VALUE ZERO.
  9064. 138300         05  FILLER   PIC XX  VALUE SPACE.
  9065. 138400 01  LTRL-AREA.
  9066. 138500     03  10ASTRKS-L  VALUE ALL "*".
  9067. 138600         05  09ASTRKS-L.
  9068. 138700         07  07ASTRKS-L.
  9069. 138800                 09  06ASTRKS-L.
  9070. 138900                     11  05ASTRKS-L.
  9071. 139000                         13  04ASTRKS-L.
  9072. 139100                             15  03ASTRKS-L.
  9073. 139200                                 17  02ASTRKS-L.
  9074. 139300                                     19  01ASTRKS-L  PIC X.
  9075. 139400                                     19  FILLER  PIC X.
  9076. 139500                                 17  FILLER  PIC X.
  9077. 139600                             15  FILLER  PIC X.
  9078. 139700                         13  FILLER  PIC X.
  9079. 139800                     11  FILLER  PIC X.
  9080. 139900                 09  FILLER  PIC X.
  9081. 140000             07  FILLER  PIC XX.
  9082. 140100         05  FILLER  PIC X.
  9083. 140200 01  TABL-AREA.
  9084. 140300     03  MON-V  PIC X(36)  VALUE   "JANFEBMARAPRMAYJUNJULAUGSEPOCT
  9085. 140400-                                  "NOVDEC".
  9086. 140500     03  MON-T  REDEFINES  MON-V  PIC XXX  OCCURS 12 TIMES.
  9087. 140600 01 P-SPACE    PIC X(132)    VALUE SPACE.
  9088. 140700 PROCEDURE DIVISION.
  9089. 140800 000-BEGIN.
  9090. 140900     ACCEPT DAT-H FROM DATE.  ACCEPT JDAY-H FROM DAY.
  9091. 141000     MOVE DAY-H TO HDR-DD.  MOVE MON-T (MON-H) TO HDR-MMM.
  9092. 141100     MOVE YER-H TO HDR-YR.
  9093. 141200     MOVE SPACE TO LAST-HLD.
  9094. 141300     READY DIC-DE.
  9095. 141400     OPEN OUTPUT FILE-P1.
  9096. 141500     IF TEST-SW = 0
  9097. 141600         OPEN INPUT FILE-D1
  9098. 141700         OPEN OUTPUT FILE-D2.
  9099. 141800 100-READ.
  9100. 141900     IF TEST-SW = 1
  9101. 142000         GO TO 105-TEST.
  9102. 142100     READ FILE-D1  AT END
  9103. 142200         DISPLAY "       IN   GOOD    BAD"
  9104. 142300         DISPLAY "V6  " CNTS-IGB-V6
  9105. 142400         DISPLAY "VP" CNTS-IGB-VP
  9106. 142500         DISPLAY "VU" CNTS-IGB-VU
  9107. 142600         DISPLAY "VF" CNTS-IGB-VF
  9108. 142700         CLOSE FILE-P1
  9109. 142800         CLOSE FILE-D1 FILE-D2
  9110. 142900         FINISH DIC-DE  STOP RUN.
  9111. 143000     MOVE FDR-D1 TO FDR-D1-WK.
  9112. 143100     GO TO 200-PROC.
  9113. 143200 105-TEST.
  9114. 143300     ADD 1 TO REC-SUB.
  9115. 143400     MOVE REC-TB (REC-SUB) TO FDR-D1-WK.
  9116. 143500     IF RT-RT (REC-SUB) = "END "
  9117. 143600         DISPLAY "         IN   GOOD    BAD"
  9118. 143700         DISPLAY "V6" CNTS-IGB-V6
  9119. 143800         DISPLAY "VP" CNTS-IGB-VP
  9120. 143900         DISPLAY "VU" CNTS-IGB-VU
  9121. 144000         DISPLAY "VF" CNTS-IGB-VF
  9122. 144100         CLOSE FILE-P1
  9123. 144200         FINISH DIC-DE  STOP RUN.
  9124. 144300 200-PROC.
  9125. 144400     MOVE ZERO TO KEY-FLG ERR-FLG AST-FLG.
  9126. 144500     IF REC-TYP-D1 = REC-TYP-HLD NEXT SENTENCE ELSE
  9127. 144600         IF REC-TYP-D1 = "VP1D"
  9128. 144700         MOVE "VP  EDIT ERROR LISTING" TO RMK-HDR-2 ELSE
  9129. 144800         IF REC-TYP-D1 = "VU1D"
  9130. 144900         MOVE "VU  EDIT ERROR LISTING" TO RMK-HDR-2 ELSE
  9131. 145000         IF REC-TYP-D1 = "V61D"
  9132. 145100         MOVE "V6  EDIT ERROR LISTING" TO RMK-HDR-2 ELSE
  9133. 145200         IF REC-TYP-D1 = "VF1D"
  9134. 145300         MOVE "VF  EDIT ERROR LISTING" TO RMK-HDR-2 ELSE
  9135. 145400         NEXT SENTENCE.
  9136. 145500     MOVE CNTL-D1 TO CNTL-HLD.
  9137. 145600     IF ACTN-D1 = "A" OR "C" OR "D"
  9138. 145700         NEXT SENTENCE ELSE
  9139. 145800         MOVE "*" TO ACTN-HLD-AST
  9140. 145900         MOVE 1 TO KEY-FLG.
  9141. 146000     IF REC-TYP-HLD = "V61D"
  9142. 146100         ADD 1 TO V6-I
  9143. 146200         MOVE FDR-D1-WK TO REC-V6-X
  9144. 146300         PERFORM 300-EDIT-V6 THRU 320-EDIT-V6-EXIT.
  9145. 146400     IF REC-TYP-HLD = "VU1D"
  9146. 146500         ADD 1 TO VU-I
  9147. 146600         MOVE FDR-D1-WK TO REC-VU-X
  9148. 146700         PERFORM 500-EDIT-VU THRU 540-EDIT-VU-EXIT.
  9149. 146800     IF REC-TYP-HLD = "VF1D"
  9150. 146900         ADD 1 TO VF-I
  9151. 147000         MOVE FDR-D1-WK TO REC-VF-X
  9152. 147100         PERFORM 600-EDIT-VF THRU 640-EDIT-VF-EXIT.
  9153. 147200     IF REC-TYP-HLD = "VP1D"
  9154. 147300         ADD 1 TO VP-I
  9155. 147400         MOVE FDR-D1-WK TO REC-VP-X
  9156. 147500         PERFORM 400-EDIT-VP THRU 430-EDIT-VP-EXIT.
  9157. 147600     IF REC-TYP-HLD = "VU1D" OR "VP1D" OR "VF1D" OR "V61D"
  9158. 147700         GO TO 100-READ.
  9159. 147800     DISPLAY "BAD RECORD".
  9160. 147900     DISPLAY FDR-D1-WK.
  9161. 148000     GO TO 100-READ.
  9162. 148100 210-DB-SDRP.
  9163. 148200     MOVE CNTL-D1 TO CNTL-HLD.
  9164. 148300     MOVE ZERO TO KEY-FLG.
  9165. 148400     IF ST-D1 = ST-LP
  9166. 148500         GO TO 220-CK-DIST.
  9167. 148600     MOVE 99 TO LIN-CNT.
  9168. 148700     MOVE ST-HLD TO DE-CD-8822-DEC.
  9169. 148800     MOVE 0003 TO DE-NO-8801-DEC.
  9170. 148900     FIND ANY CODE-DEC.
  9171. 149000     MOVE DB-STATUS TO DATA-BASE-STATUS.
  9172. 149100     IF OK
  9173. 149200         GET CODE-DEC
  9174. 149300             MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD
  9175. 149400             MOVE ST-NM-HLD TO HDR-ST-NM
  9176. 149500         ELSE MOVE "UNKNOWN" TO HDR-ST-NM
  9177. 149600             HDR-DIST-NM
  9178. 149700             MOVE 1 TO KEY-FLG
  9179. 149800             MOVE 02ASTRKS-L TO ST-HLD-AST
  9180. 149900             GO TO 250-EXIT.
  9181. 150000 220-CK-DIST.
  9182. 150100     IF SD-D1 = SD-LP
  9183. 150200         GO TO 230-CK-RA.
  9184. 150300     MOVE SD-HLD TO DE-CD-8822-DEC.
  9185. 150400     MOVE 0003 TO DE-NO-8801-DEC.
  9186. 150500     FIND ANY CODE-DEC.
  9187. 150600     MOVE DB-STATUS TO DATA-BASE-STATUS.
  9188. 150700     IF OK
  9189. 150800         GET CODE-DEC
  9190. 150900         ELSE MOVE "UNKNOWN" TO HDR-DIST-NM
  9191. 151000             MOVE 1 TO KEY-FLG
  9192. 151100             MOVE 02ASTRKS-L TO DIST-HLD-AST
  9193. 151200             GO TO 250-EXIT.
  9194. 151300     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  9195. 151400     MOVE DB-STATUS TO DATA-BASE-STATUS.
  9196. 151500     IF OK
  9197. 151600         GET CODE-EXPL-DECE
  9198. 151700         MOVE DE-CD-EXPLN-8827-DECE  TO EXPL-HLD
  9199. 151800         MOVE DIST-NM-HLD TO HDR-DIST-NM
  9200. 151900       ELSE
  9201. 152000         MOVE "UNKNOWN" TO HDR-DIST-NM
  9202. 152100             MOVE 1 TO KEY-FLG
  9203. 152200             MOVE 02ASTRKS-L TO DIST-HLD-AST
  9204. 152300         GO TO 250-EXIT.
  9205. 152400 230-CK-RA.
  9206. 152500     IF SDR-D1 = SDR-LP
  9207. 152600         GO TO 240-CK-PLU.
  9208. 152700     IF (RA-HLD = "99") AND (PLU-HLD NOT = "99")
  9209. 152800         MOVE 1 TO KEY-FLG
  9210. 152900         MOVE 02ASTRKS-L TO RA-HLD-AST
  9211. 153000         GO TO 250-EXIT.
  9212. 153100     IF RA-HLD = "99"
  9213. 153200         GO TO 250-EXIT.
  9214. 153300     MOVE SDR-HLD TO DE-CD-8822-DEC.
  9215. 153400     MOVE 0003 TO DE-NO-8801-DEC.
  9216. 153500     FIND ANY CODE-DEC.
  9217. 153600     MOVE DB-STATUS TO DATA-BASE-STATUS.
  9218. 153700     IF OK
  9219. 153800         GO TO 240-CK-PLU.
  9220. 153900     MOVE 1 TO KEY-FLG.
  9221. 154000     MOVE 02ASTRKS-L TO RA-HLD-AST
  9222. 154100     GO TO 250-EXIT.
  9223. 154200 240-CK-PLU.
  9224. 154300     IF SDRP-D1 = SDRP-LP
  9225. 154400         GO TO 250-EXIT.
  9226. 154500     IF PLU-HLD = "99"
  9227. 154600         GO TO 250-EXIT.
  9228. 154700     MOVE SDRP-HLD TO DE-CD-8822-DEC.
  9229. 154800     MOVE 0003 TO DE-NO-8801-DEC.
  9230. 154900     FIND ANY CODE-DEC.
  9231. 155000     MOVE DB-STATUS TO DATA-BASE-STATUS.
  9232. 155100     IF OK
  9233. 155200         GO TO 250-EXIT.
  9234. 155300     MOVE 1 TO KEY-FLG.
  9235. 155400     MOVE 02ASTRKS-L TO PLU-HLD-AST.
  9236. 155500     GO TO 250-EXIT.
  9237. 155600 250-EXIT.
  9238. 155700     EXIT.
  9239. 155800 260-DB-PLANT.
  9240. 155900     IF HLD-PLANT-CD = PLANT-CD-PREV
  9241. 156000         MOVE PLANT-TYP-FLG-PREV TO PLANT-TYP-FLG
  9242. 156100         MOVE PLANT-CD-FLG-PREV TO PLANT-CD-FLG
  9243. 156200         GO TO 260-EXIT.
  9244. 156300     MOVE HLD-PLANT-CD TO PLANT-CD-PREV.
  9245. 156400     MOVE ZERO TO PLANT-CD-FLG PLANT-CD-FLG-PREV.
  9246. 156500     IF HLD-PLANT-CD = "POTEN2 " OR "HYMEN  "
  9247. 156600         MOVE "F" TO PLANT-TYP-H PLANT-TYP-PREV
  9248. 156700           MOVE 2 TO PLANT-TYP-FLG  PLANT-TYP-FLG-PREV
  9249. 156800         GO TO 260-EXIT.
  9250. 156900     MOVE HLD-PLANT-CD TO DE-CD-8822-DEC.
  9251. 157000     MOVE 2646 TO DE-NO-8801-DEC.
  9252. 157100     FIND ANY CODE-DEC.
  9253. 157200     MOVE DB-STATUS TO DATA-BASE-STATUS.
  9254. 157300     IF NOT OK
  9255. 157400         MOVE 1 TO PLANT-CD-FLG PLANT-CD-FLG-PREV
  9256. 157500         GO TO 260-EXIT.
  9257. 157600     GET CODE-DEC.
  9258. 157700     MOVE DB-STATUS TO DATA-BASE-STATUS.
  9259. 157800     IF NOT OK
  9260. 157900         MOVE 1 TO PLANT-CD-FLG PLANT-CD-FLG-PREV
  9261. 158000         GO TO 260-EXIT.
  9262. 158100     MOVE CODE-DEC TO CODE-DEC-H.
  9263. 158200     IF PLANT-TYP-H NOT = "F" AND "G" AND "T" AND "S"
  9264. 158300         MOVE 1 TO PLANT-CD-FLG PLANT-CD-FLG-PREV
  9265. 158400         MOVE 0 TO PLANT-TYP-FLG PLANT-TYP-FLG-PREV
  9266. 158500         GO TO 260-EXIT.
  9267. 158600     IF PLANT-TYP-H = "G" MOVE 1 TO PLANT-TYP-FLG
  9268. 158700         PLANT-TYP-FLG-PREV
  9269. 158800         ELSE MOVE 2 TO PLANT-TYP-FLG PLANT-TYP-FLG-PREV.
  9270. 158900 260-EXIT.
  9271. 159000     EXIT.
  9272. 159100 280-DB-ANML.
  9273. 159200     IF HLD-ANML-CD =
  9274. 159300         "CA" OR "DM" OR "ER" OR "SH" OR "AN" OR "HO"
  9275. 159400         GO TO 290-EXIT.
  9276. 159500     MOVE HLD-ANML-CD TO DE-CD-8822-DEC.
  9277. 159600     MOVE 3929 TO DE-NO-8801-DEC.
  9278. 159700     FIND ANY CODE-DEC.
  9279. 159800     MOVE DB-STATUS TO DATA-BASE-STATUS.
  9280. 159900     IF NOT OK
  9281. 160000         MOVE 1 TO ANML-CD-FLG
  9282. 160100         GO TO 290-EXIT.
  9283. 160200     GET CODE-DEC.
  9284. 160300     IF NOT OK
  9285. 160400         MOVE 1 TO ANML-CD-FLG
  9286. 160500         GO TO 290-EXIT.
  9287. 160600 290-EXIT.
  9288. 160700     EXIT.
  9289. 160800 300-EDIT-V6.
  9290. 160900     MOVE SPACE TO AST-HLD REC-1-V6P-AST REC-2-V6-AST
  9291. 161000     EXAMINE GRP-1-V6-X REPLACING ALL SPACES BY ZEROS.
  9292. 161100     EXAMINE ADW-PCT-3546-V6-X REPLACING ALL SPACES BY ZEROS.
  9293. 161200     EXAMINE PHNO-STG-CD-3712-V6-X REPLACING ALL SPACES BY ZEROS.
  9294. 161300     PERFORM 210-DB-SDRP THRU 250-EXIT.
  9295. 161400     MOVE ST-HLD-AST TO ST-V6P-AST.
  9296. 161500     MOVE DIST-HLD-AST TO DIST-V6P-AST.
  9297. 161600     MOVE RA-HLD-AST TO RA-V6P-AST.
  9298. 161700     MOVE PLU-HLD-AST TO PLU-V6P-AST.
  9299. 161800     MOVE PLANT-CD-2646-V6-X TO HLD-PLANT-CD.
  9300. 161900     PERFORM 260-DB-PLANT THRU 260-EXIT.
  9301. 162000     MOVE PLANT-TYP-H TO PLANT-TYP-V6-X.
  9302. 162100     IF PLANT-CD-FLG = 1
  9303. 162200         MOVE 1 TO ERR-FLG
  9304. 162300         MOVE 07ASTRKS-L TO PLANT-CD-V6-AST.
  9305. 162400     IF PHNO-STG-CD-3712-V6-X > 0 AND < 9 NEXT SENTENCE ELSE
  9306. 162500         MOVE 1 TO ERR-FLG
  9307. 162600         MOVE 01ASTRKS-L TO PHNO-V6-AST.
  9308. 162700     IF GRAMS-GRN-WGT-3941-V6-X = SPACE
  9309. 162800        NEXT SENTENCE ELSE
  9310. 162900             IF (GRAMS-GRN-WGT-3941-V6-X NOT GREATER THAN ZERO) OR
  9311. 163000                 (GRAMS-GRN-WGT-3941-V6-X NOT NUMERIC)
  9312. 163100                 MOVE ALL "*" TO  GRN-WGT-V6-AST
  9313. 163200                 MOVE 1 TO ERR-FLG.
  9314. 163300     IF GRAMS-DRY-WGT-3942-V6-X = SPACE
  9315. 163400        NEXT SENTENCE ELSE
  9316. 163500             IF (GRAMS-DRY-WGT-3942-V6-X NOT GREATER THAN ZERO) OR
  9317. 163600                 (GRAMS-DRY-WGT-3942-V6-X NOT NUMERIC)
  9318. 163700                 MOVE ALL "*" TO  DW-V6-AST
  9319. 163800                 MOVE 1 TO ERR-FLG.
  9320. 163900     IF PLANT-TYP-FLG = 2
  9321. 164000         MOVE ZERO TO BASAL-DIMS-MIN-V6-X
  9322. 164100         MOVE ZERO TO BASAL-DIMS-MAX-V6-X.
  9323. 164200     IF PLANT-TYP-FLG = 1
  9324. 164300         MOVE ZERO TO CROWN-DIMS-MIN-V6-X
  9325. 164400         MOVE ZERO TO CROWN-DIMS-MAX-V6-X.
  9326. 164500     IF (BASAL-DIMS-MIN-V6-X NOT NUMERIC) OR
  9327. 164600         ((PLANT-TYP-FLG = 2) AND
  9328. 164700         (BASAL-DIMS-MIN-V6-X > ZERO))
  9329. 164800         MOVE 1 TO ERR-FLG
  9330. 164900         MOVE ALL "*" TO MIN-BAD-V6-AST.
  9331. 165000     IF (BASAL-DIMS-MAX-V6-X NOT NUMERIC) OR
  9332. 165100         ((PLANT-TYP-FLG = 2) AND
  9333. 165200         (BASAL-DIMS-MAX-V6-X > ZERO))
  9334. 165300         MOVE 1 TO ERR-FLG
  9335. 165400         MOVE ALL "*" TO MAX-BAD-V6-AST.
  9336. 165500     IF (CROWN-DIMS-MIN-V6-X NOT NUMERIC) OR
  9337. 165600         ((PLANT-TYP-FLG = 1) AND
  9338. 165700         (CROWN-DIMS-MIN-V6-X > ZERO))
  9339. 165800         MOVE 1 TO ERR-FLG
  9340. 165900         MOVE ALL "*" TO MIN-CRND-V6-AST.
  9341. 166000     IF (CROWN-DIMS-MAX-V6-X NOT NUMERIC) OR
  9342. 166100         ((PLANT-TYP-FLG = 1) AND
  9343. 166200         (CROWN-DIMS-MAX-V6-X > ZERO))
  9344. 166300         MOVE 1 TO ERR-FLG
  9345. 166400         MOVE ALL "*" TO MAX-CRND-V6-AST.
  9346. 166500     IF HGT-AVG-V6-X = SPACE
  9347. 166600        NEXT SENTENCE ELSE
  9348. 166700             IF HGT-AVG-V6-X NOT NUMERIC
  9349. 166800                 MOVE ALL "*" TO  HGT-V6-AST
  9350. 166900                 MOVE 1 TO ERR-FLG.
  9351. 167000     IF AVG-LDR-V6-X = SPACE
  9352. 167100        NEXT SENTENCE ELSE
  9353. 167200             IF AVG-LDR-V6-X NOT NUMERIC
  9354. 167300                 MOVE ALL "*" TO  AVG-LDR-V6-AST
  9355. 167400                 MOVE 1 TO ERR-FLG.
  9356. 167500 310-PRINT.
  9357. 167600     MOVE ERR-FLG TO AST-FLG.
  9358. 167700     IF KEY-FLG = 1 MOVE 1 TO ERR-FLG.
  9359. 167800     MOVE REC-V6-X TO REC-V6-Z.
  9360. 167900     IF ERR-FLG = ZERO
  9361. 168000         WRITE FDR-D2 FROM REC-V6-Z
  9362. 168100         ADD 1 TO V6-G
  9363. 168200         GO TO 320-EDIT-V6-EXIT
  9364. 168300         ELSE
  9365. 168400     ADD 1 TO V6-B.
  9366. 168500     IF CUR-PRINT NOT = LAST-PRINT
  9367. 168600         MOVE MSG-1-V6P TO HDR-3
  9368. 168700         MOVE MSG-2-V6 TO HDR-4
  9369. 168800         PERFORM 800-OFLO THRU 800-EXIT
  9370. 168900         PERFORM 720-PRINT-V6-1 THRU 720-EXIT-1.
  9371. 169000     IF LIN-CNT > 51
  9372. 169100         PERFORM 800-OFLO THRU 800-EXIT.
  9373. 169200     IF HEAD-SW = 1
  9374. 169300         MOVE ZERO TO HEAD-SW
  9375. 169400         PERFORM 720-PRINT-V6-2 THRU 720-EXIT
  9376. 169500              ELSE
  9377. 169600         PERFORM 720-PRINT-V6-3 THRU 720-EXIT.
  9378. 169700 320-EDIT-V6-EXIT.
  9379. 169800     EXIT.
  9380. 169900 400-EDIT-VP.
  9381. 170000     MOVE SPACE TO REC-2-VF-P.
  9382. 170100     MOVE SPACE TO AST-HLD REC-1-V6P-AST REC-2-VP-AST
  9383. 170200     EXAMINE PHNO-GP-VP-X REPLACING ALL SPACES BY ZEROS.
  9384. 170300     PERFORM 210-DB-SDRP THRU 250-EXIT.
  9385. 170400     MOVE ST-HLD-AST TO ST-V6P-AST.
  9386. 170500     MOVE DIST-HLD-AST TO DIST-V6P-AST.
  9387. 170600     MOVE RA-HLD-AST TO RA-V6P-AST.
  9388. 170700     MOVE PLU-HLD-AST TO PLU-V6P-AST.
  9389. 170800     MOVE PLANT-CD-2646-VP-X TO HLD-PLANT-CD.
  9390. 170900     PERFORM 260-DB-PLANT THRU 260-EXIT.
  9391. 171000     MOVE PLANT-TYP-H TO PLANT-TYP-3590-VP-X.
  9392. 171100     IF PLANT-CD-FLG = 1
  9393. 171200         MOVE 1 TO ERR-FLG
  9394. 171300         MOVE 07ASTRKS-L TO PLANT-CD-VP-AST.
  9395. 171400     MOVE ZERO TO SUB PHNO-CNT.
  9396. 171500 410-LP.
  9397. 171600     ADD 1 TO SUB.
  9398. 171700     IF (SUB = 9) AND (PHNO-CNT = 8)
  9399. 171800         MOVE 05ASTRKS-L TO PHNO-PCT-VP-AST (1)
  9400. 171900         MOVE 1 TO ERR-FLG.
  9401. 172000     IF SUB = 9 GO TO 420-PRINT.
  9402. 172100     IF (PHNO-ADJ-VP-X (SUB) = ZERO)
  9403. 172200         ADD 1 TO PHNO-CNT
  9404. 172300         GO TO 410-LP.
  9405. 172400     IF (PHNO-ADJ-VP-X (SUB) NOT NUMERIC)
  9406. 172500         MOVE 05ASTRKS-L TO PHNO-PCT-VP-AST (SUB)
  9407. 172600         MOVE 1 TO ERR-FLG.
  9408. 172700     GO TO 410-LP.
  9409. 172800 420-PRINT.
  9410. 172900     MOVE ERR-FLG TO AST-FLG.
  9411. 173000     IF KEY-FLG = 1 MOVE 1 TO ERR-FLG.
  9412. 173100     MOVE REC-VP-X TO REC-VP-Z.
  9413. 173200     IF ERR-FLG = ZERO
  9414. 173300         WRITE FDR-D2 FROM REC-VP-Z
  9415. 173400         ADD 1 TO VP-G
  9416. 173500         GO TO 430-EDIT-VP-EXIT
  9417. 173600         ELSE
  9418. 173700     ADD 1 TO VP-B.
  9419. 173800     IF CUR-PRINT NOT = LAST-PRINT
  9420. 173900         MOVE MSG-1-V6P TO HDR-3
  9421. 174000         MOVE MSG-2-VP TO HDR-4
  9422. 174100         PERFORM 800-OFLO THRU 800-EXIT
  9423. 174200         PERFORM 710-PRINT-VP-1 THRU 710-EXIT-1.
  9424. 174300     IF LIN-CNT > 51
  9425. 174400         PERFORM 800-OFLO THRU 800-EXIT.
  9426. 174500     IF HEAD-SW = 1
  9427. 174600         MOVE ZERO TO HEAD-SW
  9428. 174700         PERFORM 710-PRINT-VP-2 THRU 710-EXIT
  9429. 174800              ELSE
  9430. 174900         PERFORM 710-PRINT-VP-3 THRU 710-EXIT.
  9431. 175000 430-EDIT-VP-EXIT.
  9432. 175100     EXIT.
  9433. 175200 500-EDIT-VU.
  9434. 175300     MOVE SPACE TO AST-HLD REC-1-VU-AST REC-2-VU-AST
  9435. 175400     EXAMINE AUF-3928-VU-X-RD REPLACING ALL SPACES BY ZEROS.
  9436. 175500     EXAMINE PUF-3511-VU-X-RD REPLACING ALL SPACES BY ZEROS.
  9437. 175600     PERFORM 210-DB-SDRP THRU 250-EXIT.
  9438. 175700     MOVE ST-HLD-AST TO ST-VU-AST.
  9439. 175800     MOVE DIST-HLD-AST TO DIST-VU-AST.
  9440. 175900     MOVE RA-HLD-AST TO RA-VU-AST.
  9441. 176000     MOVE PLU-HLD-AST TO PLU-VU-AST.
  9442. 176100     MOVE PLANT-CD-2646-VU-X TO HLD-PLANT-CD.
  9443. 176200     PERFORM 260-DB-PLANT THRU 260-EXIT.
  9444. 176300     MOVE PLANT-TYP-H TO PLANT-TYP-3590-VU-X.
  9445. 176400     IF PLANT-CD-FLG = 1
  9446. 176500         MOVE 1 TO ERR-FLG
  9447. 176600         MOVE 07ASTRKS-L TO PLANT-CD-VU-AST.
  9448. 176700     IF DIET-USE-TYP-3917-VU-X = "D" OR "P"
  9449. 176800         NEXT SENTENCE ELSE
  9450. 176900             MOVE 01ASTRKS-L TO PUFDT-VU-AST
  9451. 177000             MOVE 1 TO KEY-FLG.
  9452. 177100     IF ANML-GRZG-CD-3929-VU-X =
  9453. 177200         "CA" OR "DM" OR "ER" OR "SH" OR "AN" OR "HO"
  9454. 177300         MOVE ZERO TO SUB AUF-CNT
  9455. 177400         GO TO 510-LP.
  9456. 177500*    MOVE ANML-GRZG-CD-3929-VU-X TO DE-CD-8822-DEC.
  9457. 177600*    MOVE 3929 TO DE-NO-8801-DEC.  FIND ANY CODE-DEC.
  9458. 177700*    MOVE DB-STATUS TO DATA-BASE-STATUS.
  9459. 177800*    IF NOT OK
  9460. 177900*        MOVE 02ASTRKS-L TO ANML-SP-VU-AST
  9461. 178000*        MOVE 1 TO ERR-FLG.
  9462. 178100     MOVE ZERO TO SUB AUF-CNT.
  9463. 178200 510-LP.
  9464. 178300     ADD 1 TO SUB.
  9465. 178400*    IF (SUB = 6) AND (AUF-CNT = 5)
  9466. 178500*        MOVE 03ASTRKS-L TO PLNT-SPG-VU-AST
  9467. 178600*        MOVE 1 TO ERR-FLG.
  9468. 178700     IF SUB = 6
  9469. 178800         MOVE ZERO TO SUB PUF-CNT
  9470. 178900         GO TO 520-LP.
  9471. 179000     IF (AUF-3928-VU-X (SUB) = ZERO)
  9472. 179100         ADD 1 TO AUF-CNT
  9473. 179200         GO TO 510-LP.
  9474. 179300     IF (AUF-3928-VU-X (SUB) NOT NUMERIC)
  9475. 179400         MOVE 03ASTRKS-L TO AUF-PCT-VU-AST (SUB)
  9476. 179500         MOVE 1 TO ERR-FLG.
  9477. 179600     GO TO 510-LP.
  9478. 179700 520-LP.
  9479. 179800     ADD 1 TO SUB.
  9480. 179900*    IF (SUB = 6) AND (PUF-CNT = 5)
  9481. 180000*        MOVE 02ASTRKS-L TO ANML-SPG-VU-AST
  9482. 180100*        MOVE 1 TO ERR-FLG.
  9483. 180200     IF SUB = 6 GO TO 530-PRINT.
  9484. 180300     IF (PUF-3511-VU-X (SUB) = ZERO)
  9485. 180400         ADD 1 TO PUF-CNT
  9486. 180500         GO TO 520-LP.
  9487. 180600     IF (PUF-3511-VU-X (SUB) NOT NUMERIC)
  9488. 180700         MOVE 02ASTRKS-L TO PUF-VU-AST (SUB)
  9489. 180800         MOVE 1 TO ERR-FLG.
  9490. 180900     GO TO 520-LP.
  9491. 181000 530-PRINT.
  9492. 181100     MOVE ERR-FLG TO AST-FLG.
  9493. 181200     IF KEY-FLG = 1 MOVE 1 TO ERR-FLG.
  9494. 181300     MOVE REC-VU-X TO REC-VU-Z.
  9495. 181400     IF ERR-FLG = ZERO
  9496. 181500         WRITE FDR-D2 FROM REC-VU-Z
  9497. 181600         ADD 1 TO VU-G
  9498. 181700         GO TO 540-EDIT-VU-EXIT
  9499. 181800         ELSE
  9500. 181900     ADD 1 TO VU-B.
  9501. 182000     IF CUR-PRINT NOT = LAST-PRINT
  9502. 182100         MOVE MSG-1-VU TO HDR-3
  9503. 182200         MOVE MSG-2-VU TO HDR-4
  9504. 182300         PERFORM 800-OFLO THRU 800-EXIT
  9505. 182400         PERFORM 730-PRINT-VU-1 THRU 730-EXIT-1.
  9506. 182500     IF LIN-CNT > 51
  9507. 182600         PERFORM 800-OFLO THRU 800-EXIT.
  9508. 182700     IF HEAD-SW = 1
  9509. 182800         MOVE ZERO TO HEAD-SW
  9510. 182900         PERFORM 730-PRINT-VU-2 THRU 730-EXIT
  9511. 183000              ELSE
  9512. 183100         PERFORM 730-PRINT-VU-3 THRU 730-EXIT.
  9513. 183200 540-EDIT-VU-EXIT.
  9514. 183300     EXIT.
  9515. 183400 600-EDIT-VF.
  9516. 183500     MOVE SPACE TO AST-HLD REC-1-VF-AST REC-2-VF-AST
  9517. 183600     EXAMINE MON-FORG-RQMT-LBS-3551-VF-X REPLACING ALL SPACES
  9518. 183700         BY ZEROS.
  9519. 183800     PERFORM 210-DB-SDRP THRU 250-EXIT.
  9520. 183900     MOVE ST-HLD-AST TO ST-VF-AST.
  9521. 184000     MOVE DIST-HLD-AST TO DIST-VF-AST.
  9522. 184100     IF ANML-HGT-CLS-CD-3548-VF-X = "1" OR "2" OR "3" OR "4"
  9523. 184200         NEXT SENTENCE ELSE
  9524. 184300             MOVE 01ASTRKS-L TO HT-CLS-AV-VF-AST
  9525. 184400             MOVE 1 TO ERR-FLG.
  9526. 184500     IF (MON-FORG-RQMT-LBS-3551-VF-X  NOT NUMERIC)
  9527. 184600         MOVE 04ASTRKS-L TO MON-FORG-VF-AST
  9528. 184700         MOVE 1 TO ERR-FLG.
  9529. 184800     IF ANML-GRZG-CD-3929-VF-X =
  9530. 184900         "CA" OR "DM" OR "ER" OR "SH" OR "AN" OR "HO"
  9531. 185000         GO TO 610-PRINT.
  9532. 185100*    MOVE ANML-GRZG-CD-3929-VF-X TO DE-CD-8822-DEC.
  9533. 185200*    MOVE 3929 TO DE-NO-8801-DEC.  FIND ANY CODE-DEC.
  9534. 185300*    MOVE DB-STATUS TO DATA-BASE-STATUS.
  9535. 185400*    IF NOT OK
  9536. 185500*        MOVE 02ASTRKS-L TO ANML-SP-VF-AST
  9537. 185600*        MOVE 1 TO ERR-FLG.
  9538. 185700 610-PRINT.
  9539. 185800     MOVE ERR-FLG TO AST-FLG.
  9540. 185900     IF KEY-FLG = 1 MOVE 1 TO ERR-FLG.
  9541. 186000     MOVE REC-VF-X TO REC-VF-Z.
  9542. 186100     IF ERR-FLG = ZERO
  9543. 186200         WRITE FDR-D2 FROM REC-VF-Z
  9544. 186300         ADD 1 TO VF-G
  9545. 186400         GO TO 640-EDIT-VF-EXIT
  9546. 186500         ELSE
  9547. 186600     ADD 1 TO VF-B.
  9548. 186700     IF CUR-PRINT NOT = LAST-PRINT
  9549. 186800         MOVE MSG-1-VF TO HDR-3
  9550. 186900         MOVE MSG-2-VF TO HDR-4
  9551. 187000         PERFORM 800-OFLO THRU 800-EXIT
  9552. 187100         PERFORM 700-PRINT-VF-1 THRU 700-EXIT-1.
  9553. 187200     IF LIN-CNT > 51
  9554. 187300         PERFORM 800-OFLO THRU 800-EXIT.
  9555. 187400     IF HEAD-SW = 1
  9556. 187500         MOVE ZERO TO HEAD-SW
  9557. 187600         PERFORM 700-PRINT-VF-2 THRU 700-EXIT
  9558. 187700              ELSE
  9559. 187800         PERFORM 700-PRINT-VF-3 THRU 700-EXIT.
  9560. 187900 640-EDIT-VF-EXIT.
  9561. 188000     EXIT.
  9562. 188100 700-PRINT-VF-1.
  9563. 188200     MOVE SPACE TO REC-1-VF-P.
  9564. 188300     MOVE DIC-VF-X TO REC-VF-P.
  9565. 188400     MOVE BLM-ADM-U-0003-ST-VF-X TO ST-VF-P.
  9566. 188500     MOVE BLM-ADM-U-0003-DIST-VF-X TO DIST-VF-P.
  9567. 188600     MOVE DATA-DATE-6618-VF-X TO DATE-VF-P.
  9568. 188700     MOVE ACTN-CD-7350-VF-X TO ACTN-VF-P.
  9569. 188800     WRITE FDR-P1 FROM VF-HDR-REC1 AFTER ADVANCING 2 LINES.
  9570. 188900     WRITE FDR-P1 FROM VF-HDR-REC2 AFTER ADVANCING 1 LINES.
  9571. 189000     WRITE FDR-P1 FROM VF-HDR-REC3 AFTER ADVANCING 1 LINES.
  9572. 189100     WRITE FDR-P1 FROM REC-1-VF-P AFTER ADVANCING 2 LINES.
  9573. 189200     WRITE FDR-P1 FROM REC-1-VF-AST AFTER ADVANCING 1 LINES.
  9574. 189300     ADD 7 TO LIN-CNT.
  9575. 189400 700-EXIT-1.
  9576. 189500     EXIT.
  9577. 189600 700-PRINT-VF-2.
  9578. 189700     WRITE FDR-P1 FROM VF-HDR-REC4 AFTER ADVANCING 2 LINES.
  9579. 189800     WRITE FDR-P1 FROM VF-HDR-REC5 AFTER ADVANCING 1 LINES.
  9580. 189900     WRITE FDR-P1 FROM VF-HDR-REC6 AFTER ADVANCING 1 LINES.
  9581. 190000     ADD 4 TO LIN-CNT.
  9582. 190100 700-PRINT-VF-3.
  9583. 190200     MOVE SPACE TO REC-2-VF-P.
  9584. 190300     MOVE LIN-NUM-3578-VF-X TO LINE-VF-P.
  9585. 190400     MOVE ANML-GRZG-CD-3929-VF-X TO ANML-SP-VF-P.
  9586. 190500     MOVE MON-FORG-RQMT-LBS-3551-VF-X TO MON-FORG-VF-P.
  9587. 190600     MOVE ANML-HGT-CLS-CD-3548-VF-X TO HT-CLS-AV-VF-P.
  9588. 190700     ADD 2 TO LIN-CNT.
  9589. 190800     WRITE FDR-P1 FROM REC-2-VF-P AFTER ADVANCING 2 LINES.
  9590. 190900     IF AST-FLG = 1
  9591. 191000         WRITE FDR-P1 FROM REC-2-VF-AST AFTER ADVANCING 1 LINES
  9592. 191100         ADD 1 TO LIN-CNT.
  9593. 191200 700-EXIT.
  9594. 191300     EXIT.
  9595. 191400 710-PRINT-VP-1.
  9596. 191500     MOVE SPACE TO REC-1-V6P-P.
  9597. 191600     MOVE DIC-VP-X TO REC-V6P-P.
  9598. 191700     MOVE BLM-ADM-U-0003-ST-VP-X TO ST-V6P-P.
  9599. 191800     MOVE BLM-ADM-U-0003-DIST-VP-X TO DIST-V6P-P.
  9600. 191900     MOVE BLM-ADM-U-0003-RA-VP-X TO RA-V6P-P.
  9601. 192000     MOVE BLM-ADM-U-0003-PLU-VP-X TO PLU-V6P-P.
  9602. 192100     MOVE DATA-DATE-6618-VP-X TO DATE-V6P-P.
  9603. 192200     MOVE ACTN-CD-7350-VP-X TO ACTN-V6P-P.
  9604. 192300     WRITE FDR-P1 FROM V6P-HDR-REC1 AFTER ADVANCING 2 LINES.
  9605. 192400     WRITE FDR-P1 FROM V6P-HDR-REC2 AFTER ADVANCING 1 LINES.
  9606. 192500     WRITE FDR-P1 FROM V6P-HDR-REC3 AFTER ADVANCING 1 LINES.
  9607. 192600     WRITE FDR-P1 FROM REC-1-V6P-P AFTER ADVANCING 2 LINES.
  9608. 192700     WRITE FDR-P1 FROM REC-1-V6P-AST AFTER ADVANCING 1 LINES.
  9609. 192800     ADD 7 TO LIN-CNT.
  9610. 192900 710-EXIT-1.
  9611. 193000     EXIT.
  9612. 193100 710-PRINT-VP-2.
  9613. 193200     WRITE FDR-P1 FROM VP-HDR-REC4 AFTER ADVANCING 2 LINES.
  9614. 193300     WRITE FDR-P1 FROM VP-HDR-REC5 AFTER ADVANCING 1 LINES.
  9615. 193400     WRITE FDR-P1 FROM VP-HDR-REC6 AFTER ADVANCING 1 LINES.
  9616. 193500     ADD 4 TO LIN-CNT.
  9617. 193600 710-PRINT-VP-3.
  9618. 193700     MOVE SPACE TO REC-2-VP-P.
  9619. 193800     MOVE LIN-NUM-3578-VP-X TO LINE-VP-P.
  9620. 193900     MOVE PLANT-CD-2646-VP-X TO PLANT-CD-VP-P.
  9621. 194000     IF PHNO-ADJ-VP-X (1) NOT = SPACE AND ZERO
  9622. 194100         MOVE PHNO-ADJ-1-VP-X (1) TO PHNO-PCT-VP-P1 (1)
  9623. 194200         MOVE PHNO-ADJ-2-VP-X (1) TO PHNO-PCT-VP-P3 (1)
  9624. 194300         MOVE "." TO PHNO-PCT-VP-P2 (1).
  9625. 194400     IF PHNO-ADJ-VP-X (2) NOT = SPACE AND ZERO
  9626. 194500         MOVE PHNO-ADJ-1-VP-X (2) TO PHNO-PCT-VP-P1 (2)
  9627. 194600         MOVE PHNO-ADJ-2-VP-X (2) TO PHNO-PCT-VP-P3 (2)
  9628. 194700         MOVE "." TO PHNO-PCT-VP-P2 (2).
  9629. 194800     IF PHNO-ADJ-VP-X (3) NOT = SPACE AND ZERO
  9630. 194900         MOVE PHNO-ADJ-1-VP-X (3) TO PHNO-PCT-VP-P1 (3)
  9631. 195000         MOVE PHNO-ADJ-2-VP-X (3) TO PHNO-PCT-VP-P3 (3)
  9632. 195100         MOVE "." TO PHNO-PCT-VP-P2 (3).
  9633. 195200     IF PHNO-ADJ-VP-X (4) NOT = SPACE AND ZERO
  9634. 195300         MOVE PHNO-ADJ-1-VP-X (4) TO PHNO-PCT-VP-P1 (4)
  9635. 195400         MOVE PHNO-ADJ-2-VP-X (4) TO PHNO-PCT-VP-P3 (4)
  9636. 195500         MOVE "." TO PHNO-PCT-VP-P2 (4).
  9637. 195600     IF PHNO-ADJ-VP-X (5) NOT = SPACE AND ZERO
  9638. 195700         MOVE PHNO-ADJ-1-VP-X (5) TO PHNO-PCT-VP-P1 (5)
  9639. 195800         MOVE PHNO-ADJ-2-VP-X (5) TO PHNO-PCT-VP-P3 (5)
  9640. 195900         MOVE "." TO PHNO-PCT-VP-P2 (5).
  9641. 196000     IF PHNO-ADJ-VP-X (6) NOT = SPACE AND ZERO
  9642. 196100         MOVE PHNO-ADJ-1-VP-X (6) TO PHNO-PCT-VP-P1 (6)
  9643. 196200         MOVE PHNO-ADJ-2-VP-X (6) TO PHNO-PCT-VP-P3 (6)
  9644. 196300         MOVE "." TO PHNO-PCT-VP-P2 (6).
  9645. 196400     IF PHNO-ADJ-VP-X (7) NOT = SPACE AND ZERO
  9646. 196500         MOVE PHNO-ADJ-1-VP-X (7) TO PHNO-PCT-VP-P1 (7)
  9647. 196600         MOVE PHNO-ADJ-2-VP-X (7) TO PHNO-PCT-VP-P3 (7)
  9648. 196700         MOVE "." TO PHNO-PCT-VP-P2 (7).
  9649. 196800     IF PHNO-ADJ-VP-X (8) NOT = SPACE AND ZERO
  9650. 196900         MOVE PHNO-ADJ-1-VP-X (8) TO PHNO-PCT-VP-P1 (8)
  9651. 197000         MOVE PHNO-ADJ-2-VP-X (8) TO PHNO-PCT-VP-P3 (8)
  9652. 197100         MOVE "." TO PHNO-PCT-VP-P2 (8).
  9653. 197200     WRITE FDR-P1 FROM REC-2-VP-P AFTER ADVANCING 2 LINES.
  9654. 197300     ADD 2 TO LIN-CNT.
  9655. 197400     IF AST-FLG = 1
  9656. 197500         WRITE FDR-P1 FROM REC-2-VP-AST AFTER ADVANCING 1 LINES
  9657. 197600         ADD 1 TO LIN-CNT.
  9658. 197700 710-EXIT.
  9659. 197800     EXIT.
  9660. 197900 720-PRINT-V6-1.
  9661. 198000     MOVE SPACE TO REC-1-V6P-P.
  9662. 198100     MOVE DIC-V6-X TO REC-V6P-P.
  9663. 198200     MOVE BLM-ADM-U-0003-ST-V6-X TO ST-V6P-P.
  9664. 198300     MOVE BLM-ADM-U-0003-DIST-V6-X TO DIST-V6P-P.
  9665. 198400     MOVE BLM-ADM-U-0003-RA-V6-X TO RA-V6P-P.
  9666. 198500     MOVE BLM-ADM-U-0003-PLU-V6-X TO PLU-V6P-P.
  9667. 198600     MOVE DATA-DATE-6618-V6-X TO DATE-V6P-P.
  9668. 198700     MOVE ACTN-CD-7350-V6-X TO ACTN-V6P-P.
  9669. 198800     WRITE FDR-P1 FROM V6P-HDR-REC1 AFTER ADVANCING 2 LINES.
  9670. 198900     WRITE FDR-P1 FROM V6P-HDR-REC2 AFTER ADVANCING 1 LINES.
  9671. 199000     WRITE FDR-P1 FROM V6P-HDR-REC3 AFTER ADVANCING 1 LINES.
  9672. 199100     WRITE FDR-P1 FROM REC-1-V6P-P AFTER ADVANCING 2 LINES.
  9673. 199200     WRITE FDR-P1 FROM REC-1-V6P-AST AFTER ADVANCING 1 LINES.
  9674. 199300     ADD 7 TO LIN-CNT.
  9675. 199400 720-EXIT-1.
  9676. 199500     EXIT.
  9677. 199600 720-PRINT-V6-2.
  9678. 199700     WRITE FDR-P1 FROM V6-HDR-REC4 AFTER ADVANCING 2 LINES.
  9679. 199800     WRITE FDR-P1 FROM V6-HDR-REC5 AFTER ADVANCING 1 LINES.
  9680. 199900     WRITE FDR-P1 FROM V6-HDR-REC6 AFTER ADVANCING 1 LINES.
  9681. 200000     ADD 4 TO LIN-CNT.
  9682. 200100 720-PRINT-V6-3.
  9683. 200200     MOVE SPACE TO REC-2-V6-P.
  9684. 200300     MOVE LIN-NUM-3578-V6-X TO LINE-V6-P.
  9685. 200400     MOVE PLANT-CD-2646-V6-X TO PLANT-CD-V6-P.
  9686. 200500     MOVE PHNO-STG-CD-3712-V6-X TO PHNO-V6-P.
  9687. 200600     MOVE GRAMS-GRN-WGT-3941-V6-X TO GRN-WGT-V6-P.
  9688. 200700     MOVE GRAMS-DRY-WGT-3942-V6-X TO DW-V6-P.
  9689. 200800     MOVE ADW-PCT-3546-V6-X TO PCT-DW-V6-P.
  9690. 200900     IF BASAL-DIMS-MIN-V6-X NOT = SPACE AND ZERO
  9691. 201000         MOVE BAD-MIN-1-V6-X TO MIN-BAD-V6-P1
  9692. 201100         MOVE BAD-MIN-2-V6-X TO MIN-BAD-V6-P3
  9693. 201200         MOVE "." TO MIN-BAD-V6-P2.
  9694. 201300     IF BASAL-DIMS-MAX-V6-X NOT = SPACE AND ZERO
  9695. 201400         MOVE BAD-MAX-1-V6-X TO MAX-BAD-V6-P1
  9696. 201500         MOVE BAD-MAX-2-V6-X TO MAX-BAD-V6-P3
  9697. 201600         MOVE "." TO MAX-BAD-V6-P2.
  9698. 201700     IF CROWN-DIMS-MIN-V6-X NOT = SPACE AND ZERO
  9699. 201800         MOVE CRD-MIN-1-V6-X TO MIN-CRND-V6-P1
  9700. 201900         MOVE CRD-MIN-2-V6-X TO MIN-CRND-V6-P3
  9701. 202000         MOVE "." TO MIN-CRND-V6-P2.
  9702. 202100     IF CROWN-DIMS-MIN-V6-X NOT = SPACE AND ZERO
  9703. 202200         MOVE CRD-MAX-1-V6-X TO MAX-CRND-V6-P1
  9704. 202300         MOVE CRD-MAX-2-V6-X TO MAX-CRND-V6-P3
  9705. 202400         MOVE "." TO MAX-CRND-V6-P2.
  9706. 202500     IF HGT-AVG-V6-X NOT = SPACE AND ZERO
  9707. 202600         MOVE HGT-AVG-1-V6-X TO HGT-V6-P1
  9708. 202700         MOVE HGT-AVG-2-V6-X TO HGT-V6-P3
  9709. 202800         MOVE "." TO HGT-V6-P2.
  9710. 202900     IF AVG-LDR-V6-X NOT = SPACE AND ZERO
  9711. 203000         MOVE AVG-LDR-1-V6-X TO AVG-LDR-V6-P1
  9712. 203100         MOVE AVG-LDR-2-V6-X TO AVG-LDR-V6-P3
  9713. 203200         MOVE "." TO AVG-LDR-V6-P2.
  9714. 203300     MOVE REC-CNT-V6-X TO REC-CNT-V6-P.
  9715. 203400     WRITE FDR-P1 FROM REC-2-V6-P AFTER ADVANCING 2 LINES.
  9716. 203500     ADD 2 TO LIN-CNT.
  9717. 203600     IF AST-FLG = 1
  9718. 203700         WRITE FDR-P1 FROM REC-2-V6-AST AFTER ADVANCING 1 LINES
  9719. 203800         ADD 1 TO LIN-CNT.
  9720. 203900 720-EXIT.
  9721. 204000     EXIT.
  9722. 204100 730-PRINT-VU-1.
  9723. 204200     MOVE SPACE TO REC-1-VU-P.
  9724. 204300     MOVE DIC-VU-X TO REC-VU-P.
  9725. 204400     MOVE BLM-ADM-U-0003-ST-VU-X TO ST-VU-P.
  9726. 204500     MOVE BLM-ADM-U-0003-DIST-VU-X TO DIST-VU-P.
  9727. 204600     MOVE BLM-ADM-U-0003-RA-VU-X TO RA-VU-P.
  9728. 204700     MOVE BLM-ADM-U-0003-PLU-VU-X TO PLU-VU-P.
  9729. 204800     MOVE DATA-DATE-6618-VU-X TO DATE-VU-P.
  9730. 204900     MOVE ACTN-CD-7350-VU-X TO ACTN-VU-P.
  9731. 205000     MOVE DIET-USE-TYP-3917-VU-X TO PUFDT-VU-P.
  9732. 205100     WRITE FDR-P1 FROM VU-HDR-REC1 AFTER ADVANCING 2 LINES.
  9733. 205200     WRITE FDR-P1 FROM VU-HDR-REC2 AFTER ADVANCING 1 LINES.
  9734. 205300     WRITE FDR-P1 FROM VU-HDR-REC3 AFTER ADVANCING 1 LINES.
  9735. 205400     WRITE FDR-P1 FROM REC-1-VU-P AFTER ADVANCING 2 LINES.
  9736. 205500     WRITE FDR-P1 FROM REC-1-VU-AST AFTER ADVANCING 1 LINES.
  9737. 205600     ADD 7 TO LIN-CNT.
  9738. 205700 730-EXIT-1.
  9739. 205800     EXIT.
  9740. 205900 730-PRINT-VU-2.
  9741. 206000     MOVE SPACE TO REC-1-VU-P.
  9742. 206100     WRITE FDR-P1 FROM VU-HDR-REC4 AFTER ADVANCING 2 LINES.
  9743. 206200     WRITE FDR-P1 FROM VU-HDR-REC5 AFTER ADVANCING 1 LINES.
  9744. 206300     WRITE FDR-P1 FROM VU-HDR-REC6 AFTER ADVANCING 1 LINES.
  9745. 206400     ADD 4 TO LIN-CNT.
  9746. 206500 730-PRINT-VU-3.
  9747. 206600     MOVE SPACE TO REC-2-VU-P.
  9748. 206700     MOVE LIN-NUM-3578-VU-X TO LINE-VU-P.
  9749. 206800     MOVE PLANT-CD-2646-VU-X TO PLANT-CD-VU-P.
  9750. 206900     MOVE AUF-3928-VU-X (1) TO PLNT-SPG-VU-P.
  9751. 207000     MOVE AUF-3928-VU-X (2) TO PLNT-SUM-VU-P.
  9752. 207100     MOVE AUF-3928-VU-X (3) TO PLNT-FAL-VU-P.
  9753. 207200     MOVE AUF-3928-VU-X (4) TO PLNT-WIN-VU-P.
  9754. 207300     MOVE AUF-3928-VU-X (5) TO PLNT-YRL-VU-P.
  9755. 207400     MOVE ANML-GRZG-CD-3929-VU-X TO ANML-SP-VU-P.
  9756. 207500     MOVE PUF-3511-VU-X (1) TO ANML-SPG-VU-P.
  9757. 207600     MOVE PUF-3511-VU-X (2) TO ANML-SUM-VU-P.
  9758. 207700     MOVE PUF-3511-VU-X (3) TO ANML-FAL-VU-P.
  9759. 207800     MOVE PUF-3511-VU-X (4) TO ANML-WIN-VU-P.
  9760. 207900     MOVE PUF-3511-VU-X (5) TO ANML-YRL-VU-P.
  9761. 208000     WRITE FDR-P1 FROM REC-2-VU-P AFTER ADVANCING 2 LINES.
  9762. 208100     ADD 2 TO LIN-CNT.
  9763. 208200     IF AST-FLG = 1
  9764. 208300         WRITE FDR-P1 FROM REC-2-VU-AST AFTER ADVANCING 1 LINES
  9765. 208400         ADD 1 TO LIN-CNT.
  9766. 208500 730-EXIT.
  9767. 208600     EXIT.
  9768. 208700 800-OFLO.
  9769. 208800     MOVE 1 TO HEAD-SW.
  9770. 208900     ADD 1 TO PAG-CNT.
  9771. 209000     MOVE PAG-CNT TO HDR-PG  MOVE 3 TO LIN-CNT.
  9772. 209100     WRITE FDR-P1 FROM HDR-1 AFTER ADVANCING PAGE.
  9773. 209200     WRITE FDR-P1 FROM HDR-2 AFTER ADVANCING 2 LINES.
  9774. 209300     IF CUR-PRINT NOT = LAST-PRINT
  9775. 209400         ADD 3 TO LIN-CNT
  9776. 209500         WRITE FDR-P1 FROM HDR-3 AFTER ADVANCING 2 LINES
  9777. 209600         WRITE FDR-P1 FROM HDR-4 AFTER ADVANCING 1 LINES.
  9778. 209700     MOVE CUR-PRINT TO LAST-PRINT.
  9779. 209800 800-EXIT.
  9780. 209900     EXIT.
  9781. 210000 999-END.
  9782. 210100     STOP RUN.
  9783. 210200*991.........2........3.........4.........5.........6.........7..
  9784. 000000*-----------------------------------------------------------------
  9785. 000100 IDENTIFICATION DIVISION.
  9786. 000200 PROGRAM-ID. ES127M.
  9787. 000300*        V7 / V6 & VP PLANT MATCH (SEE REMARKS)
  9788. 000400*
  9789. 000500 AUTHOR. FRANK WILEY, RON BAKER.
  9790. 000600 DATE-WRITTEN.  29 OCT 79 CHANGE 13 DEC 79.
  9791. 000700 DATE-COMPILED.
  9792. 000800*REMARKS: THE V7 IS READ AND A SORT RECORD IS RELEASED FOR
  9793. 000900*         EACH SPECIES WITHIN THE RECORD. THESE RECORDS ARE
  9794. 001000*         SORTED BY SDRP AND SPECIES.  DUPLICATE SPECIES
  9795. 001100*         ARE WRITTEN ON AN ERROR LISTING.
  9796. 001200*         THE V6FUP AND THE V7 FILE ARE THEN  SORTED
  9797. 001300*         BY ST,DIS,RA,PLU AND SPECIES.  THE VF AND VU RECORDS
  9798. 001400*         ARE BYPASSED, THE V6 AND VP ARE
  9799. 001500*         ARE USED BY MATCHING THE V7 RECORD ON THE SORTED
  9800. 001600*         FIELDS, UNMATCHED V7 RECORDS ARE WRITTEN ON AN
  9801. 001700*         ERROR LISTING.
  9802. 001800*         RECORDS WHICH MATCH ARE LOADED INTO A TABLE AND ALL
  9803. 001900*         LIKE (SPECIES) V6,VP RECORDS ARE REPRODUCED FOR EACH
  9804. 002000*         DUPE SPECIES WITHIN THE MATCHING V7 RECORD.  THE
  9805. 002100*         V7 SPECIES ARE ALSO EDITED VS THE DATA BASE DICTIONARY
  9806. 002200*         AND NO MATCH OR BAD PLANT-TYPES ARE WRITTEN TO AN
  9807. 002300*         ERROR LISTING IN RECORD FORMAT.
  9808. 002400*         THE NEW-V6VP RECORDS ARE SORTED BEFORE FINAL OUTPUT
  9809. 002500*         TO REMOVE THE OLD DUPLICATES THAT WERE SUPERCEDED
  9810. 002600*          BY THE V7 EQUALVALENTS.
  9811. 002700 ENVIRONMENT DIVISION.
  9812. 002800 CONFIGURATION SECTION.
  9813. 002900 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  9814. 003000 OBJECT-COMPUTER.  LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
  9815. 003100 INPUT-OUTPUT SECTION.
  9816. 003200 FILE-CONTROL.
  9817. 003300     SELECT  ADW-FCTR-FILE  ASSIGN TO D1
  9818. 003400         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  9819. 003500     SELECT FILE-V7 ASSIGN TO I1
  9820. 003600         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  9821. 003700     SELECT FILE-V6FUP ASSIGN TO I2
  9822. 003800         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  9823. 003900     SELECT PRINT-FILE ASSIGN TO P1-PRINTER
  9824. 004000         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  9825. 004100     SELECT PRINT-FILE-2 ASSIGN TO P2-PRINTER
  9826. 004200         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  9827. 004300     SELECT SORT-FILE ASSIGN TO W1
  9828. 004400         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  9829. 004500 DATA DIVISION.
  9830. 004600 SUB-SCHEMA SECTION.
  9831. 004700 DB  CODVAL2 WITHIN BLMDIC.
  9832. 004800 FILE SECTION.
  9833. 004900 FD  PRINT-FILE
  9834. 005000     CODE-SET GBCD
  9835. 005100     LABEL RECORD STANDARD.
  9836. 005200 01  PRINT-REC  PIC X(132).
  9837. 005300 FD  PRINT-FILE-2
  9838. 005400     CODE-SET GBCD
  9839. 005500     LABEL RECORD STANDARD.
  9840. 005600 01  PRINT-REC-2  PIC X(132).
  9841. 005700 FD  FILE-V6FUP
  9842. 005800     CODE-SET GBCD
  9843. 005900     LABEL RECORD STANDARD.
  9844. 006000 01  V6FUP-REC.
  9845. 006100     02  FORM-CODE                    PIC XX.
  9846. 006200     02  CMPL-RCD.
  9847. 006300         03  FILLER                    PIC XX.
  9848. 006400         03  SDRP-V6                PIC X(8).
  9849. 006500         03  FILLER                    PIC X(11).
  9850. 006600         03  PLANT-SYMBOL-V6           PIC X(7).
  9851. 006700         03  FILLER                    PIC X(36).
  9852. 006800 FD  FILE-V7
  9853. 006900     CODE-SET GBCD
  9854. 007000     LABEL RECORD STANDARD.
  9855. 007100 01  RCD-V7.
  9856. 007200     02  RCD-TYPE                     PIC X(4).
  9857. 007300     02  SDRP-V7                    PIC X(8).
  9858. 007400     02  FILLER                       PIC X(7).
  9859. 007500     02  LINE-NO                      PIC 9(4).
  9860. 007600     02  PLANT-SYMBOL-V7               PIC X(7).
  9861. 007700     02  NEW-PLANT.
  9862. 007800         03  PLANT-V7     OCCURS 8    PIC X(7).
  9863. 007900     02  FILLER                       PIC X(4).
  9864. 008000 FD  ADW-FCTR-FILE
  9865. 008100     CODE-SET GBCD
  9866. 008200     LABEL RECORD STANDARD.
  9867. 008300 01  ADW-FCTR-REC.
  9868. 008400     02  REC-TYP-V6P          PIC XX.
  9869. 008500     02  FILLER          PIC XX.
  9870. 008600     02  SDRP-V6P.
  9871. 008700         04 SDR-V6P.
  9872. 008800             06 SD-V6P.
  9873. 008900                 08  ST-V6P  PIC XX.
  9874. 009000                 08  DIST-V6P PIC XX.
  9875. 009100             06  RA-V6P   PIC XX.
  9876. 009200         04  PLU-V6P    PIC XX.
  9877. 009300     02  FILLER     PIC X(6).
  9878. 009400     02  ACT-V6P  PIC X.
  9879. 009500     02  LINE-V6P  PIC XXXX.
  9880. 009600     02  PLANT-SYM-V6P               PIC X(7).
  9881. 009700     02  PHENO-V6P    PIC X.
  9882. 009800     02  FILLER     PIC X(31).
  9883. 009900     02  PLANT-TYP-VP                 PIC X.
  9884. 010000     02  PLANT-TYP-V6                 PIC X.
  9885. 010100     02  FILLER                        PIC XX.
  9886. 010200 SD  SORT-FILE.
  9887. 010300 01  SORT-RCD.
  9888. 010400     02  SORT-KEY.
  9889. 010500         03  SDRP-S              PIC X(8).
  9890. 010600         03  PLANT-SYMBOL-S         PIC X(7).
  9891. 010700         03  S-NUM                      PIC X(01).
  9892. 010800     02  DATA-S                     PIC X(90).
  9893. 010900     02  FILLER                        PIC XX.
  9894. 011000 01  SORT-TWO.
  9895. 011100     02  FILLER                      PIC X(4).
  9896. 011200     02  SDRP-S7                  PIC X(8).
  9897. 011300     02  FILLER                      PIC X(11).
  9898. 011400     02  PLANT-SYM-S7                PIC X(7).
  9899. 011500     02  FILLER                      PIC X(60).
  9900. 011600 01  SORT-THREE.
  9901. 011700     03  SORT-KEY-W7.
  9902. 011800         05  SDRP-W7             PIC X(8).
  9903. 011900         05  PLANT-SYMBOL-W7     PIC X(7).
  9904. 012000     03  S-NUM-W7                PIC 9.
  9905. 012100     03  DATA-W7                 PIC X(90).
  9906. 012200     03  AST-W7                  PIC 99.
  9907. 012300 01  SORT-FOUR.
  9908. 012400     02  SR-KEY.
  9909. 012500         03  SDRP-SR.
  9910. 012600             05  ST-SR  PIC XX.
  9911. 012700             05  DS-SR  PIC XX.
  9912. 012800             05  RA-SR  PIC XX.
  9913. 012900             05  PU-SR  PIC XX.
  9914. 013000         03  PLT-TYP-SR   PIC X.
  9915. 013100         03  PLT-PHENO-SR.
  9916. 013200             05  PLT-SR   PIC X(7).
  9917. 013300             05  PHENO-SR   PIC X.
  9918. 013400         03  A-B-CD-SR  PIC X.
  9919. 013500         03  REC-TYP-SR   PIC XXXX.
  9920. 013600     02  SR-DATA     PIC X(66).
  9921. 013700 WORKING-STORAGE SECTION.
  9922. 013800 77  FIRST-SW         COMP-4      PIC 9 VALUE 1.
  9923. 013900 77  FIRST-BY-SW         COMP-4      PIC 9 VALUE 0.
  9924. 014000 77  PLANT-DISP    PIC X(7)  VALUE SPACE.
  9925. 014100 77  RTN-SW         COMP-4      PIC 9 VALUE 0.
  9926. 014200 77  LINE-CNT-2                  PIC 99 VALUE ZERO.
  9927. 014300 77  LINE-CNT                    PIC 99 VALUE ZERO.
  9928. 014400 77  CNT-12   PIC 9(8)  VALUE ZERO.
  9929. 014500 77  CNT-13   PIC 9(8)  VALUE ZERO.
  9930. 014600 77  CNT-14   PIC 9(8)  VALUE ZERO.
  9931. 014700 77  CNT-15   PIC 9(8)  VALUE ZERO.
  9932. 014800 77  CNT-16   PIC 9(8)  VALUE ZERO.
  9933. 014900 77  CNT-17   PIC 9(8)  VALUE ZERO.
  9934. 015000 77  CNT-18   PIC 9(8)  VALUE ZERO.
  9935. 015100 77  CNT-19   PIC 9(8)  VALUE ZERO.
  9936. 015200 77  CNT-20   PIC 9(8)  VALUE ZERO.
  9937. 015300 77  SORT-KEY-DUPE   PIC X(16)   VALUE SPACE.
  9938. 015400 77  ERR-SW         COMP-4      PIC 9 VALUE 0.
  9939. 015500 77  ERR-FLG         COMP-4      PIC 9 VALUE 0.
  9940. 015600 77  V7-CNTL-HLD   PIC X(15)   VALUE SPACE.
  9941. 015700 77  PG-CNT-2       PIC 9(5)    VALUE ZERO.
  9942. 015800 77  PG-CNT         PIC 9(5)    VALUE ZERO.
  9943. 015900 77  OFLO-CNT   PIC 99  VALUE ZERO.
  9944. 016000 77  W7-CNT   PIC 9(8)  VALUE ZERO.
  9945. 016100 77  SUB           COMP-4      PIC 99 VALUE 0.
  9946. 016200 77  SUB-V7           COMP-4      PIC 99 VALUE 0.
  9947. 016300 77  SUB-W7           COMP-4      PIC 99 VALUE 0.
  9948. 016400 77  EQUAL-SW              COMP-4      PIC 9 VALUE ZERO.
  9949. 016500 01  VP-BYPASS-HLD.
  9950. 016600     03  PLT-BY-VP   PIC X(7).
  9951. 016700     03  PHENO-BY-VP PIC X.
  9952. 016800 01  V6-BYPASS-HLD.
  9953. 016900     03  PLT-BY-V6   PIC X(7).
  9954. 017000     03  PHENO-BY-V6 PIC X.
  9955. 017100 01  AST-LINE.
  9956. 017200     03  FILLER    PIC X(23)    VALUE SPACE.
  9957. 017300     03  AST-P       PIC X(7).
  9958. 017400     03  AST       PIC X(7)  OCCURS 8 TIMES.
  9959. 017500     03  FILLER    PIC XXXX     VALUE SPACE.
  9960. 017600 01  SORT-HOLD-W7.
  9961. 017700     03  SORT-KEY-HOLD-W7.
  9962. 017800         05  SDRP-HOLD-W7             PIC X(8).
  9963. 017900         05  PLANT-SYMBOL-HOLD-W7     PIC X(7).
  9964. 018000     03  S-NUM-HOLD-W7                  PIC 9.
  9965. 018100     03  DATA-HOLD-W7 PIC X(90).
  9966. 018200     03  FILLER      PIC XX.
  9967. 018300 01  V7-HOLD.
  9968. 018400     02  V7-CNTL.
  9969. 018500         03  SDRP-H          PIC X(8)  VALUE SPACE.
  9970. 018600         03  PLANT-SYMBOL-H        PIC X(7)  VALUE SPACE.
  9971. 018700     02  PLANT-TAB.
  9972. 018800         03  PLANT-H    OCCURS 40 TIMES  PIC X(56).
  9973. 018900         03  TYPE-H    OCCURS 40 TIMES  PIC X(8).
  9974. 019000 01  HOLD-PLANTS.
  9975. 019100     03  HLD-PLTS    PIC X(7)   OCCURS 8 TIMES.
  9976. 019200 01  HOLD-TYPES.
  9977. 019300     03  HLD-TYPS    PIC X   OCCURS 8 TIMES.
  9978. 019400 01  WORK-TYPES.
  9979. 019500     03  WRK-TYPS    PIC X   OCCURS 8 TIMES.
  9980. 019600 01  V6-HOLD.
  9981. 019700     02  V6-CNTL.
  9982. 019800         03  SDRP-HLD               PIC X(8).
  9983. 019900         03  PLANT-SYMBOL-HLD          PIC X(7).
  9984. 020000 01  SORT-BUILD.
  9985. 020100     02  BUILD-SORT                    PIC X(66).
  9986. 020200     02  FILLER                        PIC X(24).
  9987. 020300 01  DIS-CNTS.
  9988. 020400     03  CNT-1  PIC 9(8)  VALUE ZERO.
  9989. 020500     03  FILLER  PIC X VALUE SPACE.
  9990. 020600     03  CNT-2  PIC 9(8)  VALUE ZERO.
  9991. 020700     03  FILLER  PIC X VALUE SPACE.
  9992. 020800     03  CNT-3  PIC 9(8)  VALUE ZERO.
  9993. 020900     03  FILLER  PIC X VALUE SPACE.
  9994. 021000     03  CNT-4  PIC 9(8)  VALUE ZERO.
  9995. 021100     03  FILLER  PIC X VALUE SPACE.
  9996. 021200     03  CNT-5  PIC 9(8)  VALUE ZERO.
  9997. 021300     03  FILLER  PIC X VALUE SPACE.
  9998. 021400     03  CNT-6  PIC 9(8)  VALUE ZERO.
  9999. 021500     03  FILLER  PIC X VALUE SPACE.
  10000. 021600     03  CNT-7  PIC 9(8)  VALUE ZERO.
  10001. 021700     03  FILLER  PIC X VALUE SPACE.
  10002. 021800     03  CNT-8  PIC 9(8)  VALUE ZERO.
  10003. 021900     03  FILLER  PIC X VALUE SPACE.
  10004. 022000     03  CNT-9  PIC 9(8)  VALUE ZERO.
  10005. 022100     03  FILLER  PIC X VALUE SPACE.
  10006. 022200     03  CNT-10  PIC 9(8)  VALUE ZERO.
  10007. 022300     03  FILLER  PIC X VALUE SPACE.
  10008. 022400     03  CNT-11  PIC 9(8)  VALUE ZERO.
  10009. 022500 01  BY-DISP.
  10010. 022600     03  FILLER  PIC X  VALUE SPACE.
  10011. 022700     03  ST-BY  PIC XX.
  10012. 022800     03  FILLER  PIC X  VALUE SPACE.
  10013. 022900     03  DS-BY  PIC XX.
  10014. 023000     03  FILLER  PIC X  VALUE SPACE.
  10015. 023100     03  RA-BY  PIC XX.
  10016. 023200     03  FILLER  PIC X  VALUE SPACE.
  10017. 023300     03  PU-BY  PIC XX.
  10018. 023400     03  FILLER  PIC XX  VALUE SPACE.
  10019. 023500     03  PLT-BY  PIC X(7).
  10020. 023600     03  FILLER  PIC X  VALUE SPACE.
  10021. 023700     03  REC-BY  PIC XX.
  10022. 023800 01  BY-MSG.
  10023. 023900     03  FILLER  PIC X(25)  VALUE "THE FOLLOWING PLANTS WERE".
  10024. 024000     03  FILLER  PIC X(23)  VALUE " REPLACED BY THE VALUES".
  10025. 024100     03  FILLER  PIC X(23)  VALUE " IN THEIR EQUIVALENT V7".
  10026. 024200     03  FILLER  PIC X(7)  VALUE " PLANT.".
  10027. 024300 01  BY-HDR.
  10028. 024400     03  FILLER  PIC X(22)  VALUE " ST DS RA PLU PLANT   ".
  10029. 024500     03  FILLER  PIC X(6)  VALUE "RECORD".
  10030. 024600 01  HDR-1.
  10031. 024700     05  FILLER  PIC X(24)  VALUE "    PCN: SV127E   AS OF ".
  10032. 024800     05  HDR-DD        PIC XX.
  10033. 024900     05  FILLER        PIC X         VALUE SPACE.
  10034. 025000     05  HDR-MMM       PIC XXX.
  10035. 025100     05  FILLER        PIC X         VALUE SPACE.
  10036. 025200     05  HDR-YR        PIC XX.
  10037. 025300     05  FILLER         PIC X(11)     VALUE SPACES.
  10038. 025400     05  FILLER         PIC X(45)     VALUE
  10039. 025500         "USDI- BUR OF LAND MGT  SOIL-VEG INVENT METHOD".
  10040. 025600     05  FILLER         PIC X(32)     VALUE SPACES.
  10041. 025700     05  FILLER         PIC X(5)      VALUE "PAGE:".
  10042. 025800     05  HDR-PG         PIC ZZZZZ9.
  10043. 025900 01  HDR-2.
  10044. 026000     05  FILLER        PIC X(50)     VALUE SPACES.
  10045. 026100     05  RMK-HDR-2  PIC X(16)  VALUE
  10046. 026200         "V7 ERROR LISTING".
  10047. 026300     05  RMK-HDR-2B   PIC X(21) VALUE "  (DUPLICATE SPECIES)".
  10048. 026400     05  FILLER        PIC X(45)     VALUE SPACES.
  10049. 026500 01  HDR-3.
  10050. 026600     05  FILLER        PIC X(50)     VALUE SPACES.
  10051. 026700     05  RMK-HDR-3  PIC X(16)  VALUE
  10052. 026800         "V7 ERROR LISTING".
  10053. 026900     05  RMK-HDR-3B   PIC X(24) VALUE "  (UNMATCHED V6 SPECIES)".
  10054. 027000     05  FILLER        PIC X(42)     VALUE SPACES.
  10055. 027100 COPY DBSTATUS OF TPCOBOLIB.
  10056. 027200 01  HOLD-AREA.
  10057. 027300     03  CODE-DEC-H.
  10058. 027400         05  FILLER  PIC XXXX.
  10059. 027500         05  PLANT-CD-H  PIC X(7).
  10060. 027600         05  FILLER  PIC X(24).
  10061. 027700         05  PLANT-TYP-H  PIC X.
  10062. 027800     03  DE-CD-NAM-8823-DEC-H.
  10063. 027900         05  DIST-NAM-H  PIC X(15).
  10064. 028000         05  FILLER  PIC X(9).
  10065. 028100     03  HLD-PLANT-CD    PIC X(7).
  10066. 028200     03  HLD-PLANT-TYP    PIC X.
  10067. 028300     03 DAT-H.
  10068. 028400         05  YER-H   PIC XX.
  10069. 028500         05  MON-H    PIC 99.
  10070. 028600         05  DAY-H    PIC XX.
  10071. 028700 01  TABL-AREA.
  10072. 028800     03  MON-V  PIC X(36)  VALUE   "JANFEBMARAPRMAYJUNJULAUGSEPOCT
  10073. 028900-                                  "NOVDEC".
  10074. 029000     03  MON-T  REDEFINES  MON-V  PIC XXX  OCCURS 12 TIMES.
  10075. 029100 01  HDR-5.
  10076. 029200     03  FILLER  PIC X(30)
  10077. 029300         VALUE "RECDSTDSRAPU-------LINE-PLANT-".
  10078. 029400     03  FILLER  PIC X(28)
  10079. 029500         VALUE "-PLNT1--PLNT2--PLNT3--PLNT4-".
  10080. 029600     03  FILLER  PIC X(28)
  10081. 029700         VALUE "-PLNT5--PLNT6--PLNT7--PLNT8-".
  10082. 029800     03  FILLER  PIC X(46)  VALUE SPACE.
  10083. 029900 01  DET-1.
  10084. 030000     03  FILLER  PIC X(86).
  10085. 030100     03  FILLER  PIC X(46).
  10086. 030200 01  DET-2.
  10087. 030300     03  FILLER    PIC X(30).
  10088. 030400     03  PLT-AST  PIC X(7)  OCCURS 8 TIMES.
  10089. 030500     03  FILLER  PIC X(46).
  10090. 030600 01 P-SPACE    PIC X(132)    VALUE SPACE.
  10091. 030700 PROCEDURE DIVISION.
  10092. 030800 000-BEGIN SECTION.
  10093. 030900 000-HOUSEKEEPING.
  10094. 031000     MOVE SPACE TO AST-LINE.
  10095. 031100     OPEN OUTPUT PRINT-FILE.
  10096. 031200     OPEN OUTPUT PRINT-FILE-2.
  10097. 031300     ACCEPT DAT-H FROM DATE.
  10098. 031400     MOVE DAY-H TO HDR-DD.
  10099. 031500     MOVE MON-T (MON-H) TO HDR-MMM.
  10100. 031600     MOVE YER-H TO HDR-YR.
  10101. 031700 000-OFLO.
  10102. 031800     ADD 1 TO PG-CNT-2.
  10103. 031900     MOVE 5 TO LINE-CNT-2.
  10104. 032000     WRITE PRINT-REC-2 FROM P-SPACE BEFORE PAGE.
  10105. 032100     MOVE PG-CNT-2 TO HDR-PG.
  10106. 032200     MOVE SPACE TO DET-2.
  10107. 032300     WRITE PRINT-REC-2 FROM HDR-1
  10108. 032400         AFTER 1 LINE.
  10109. 032500     WRITE PRINT-REC-2 FROM HDR-2 AFTER 2 LINES.
  10110. 032600     WRITE PRINT-REC-2 FROM HDR-5
  10111. 032700         AFTER 1 LINE.
  10112. 032800 000-EXIT.
  10113. 032900     EXIT.
  10114. 033000 000-CONTINUE.
  10115. 033100*    DISPLAY "THE FOLLOWING PAIRS OF RECORDS".
  10116. 033200*    DISPLAY "    CONTAIN DUPLICATE SPECIES CODES."
  10117. 033300*    DISPLAY " ".
  10118. 033400 010-W7-SORT SECTION.
  10119. 033500 015-SORT.
  10120. 033600     SORT SORT-FILE ON ASCENDING KEY SORT-KEY-W7, S-NUM-W7
  10121. 033700         INPUT PROCEDURE IS 020-BUILD-W7
  10122. 033800         OUTPUT PROCEDURE IS 030-DUPE-CHK.
  10123. 033900 015-W7-END.
  10124. 034000     IF W7-CNT = ZERO
  10125. 034100      DISPLAY " THERE WERE NO DUPLICATE SPECIES ON THE V7.".
  10126. 034200     CLOSE FILE-V7.
  10127. 034300 016-OFLO.
  10128. 034400     ADD 1 TO PG-CNT.
  10129. 034500     MOVE 5 TO LINE-CNT.
  10130. 034600     WRITE PRINT-REC FROM P-SPACE BEFORE PAGE.
  10131. 034700     MOVE PG-CNT TO HDR-PG.
  10132. 034800     MOVE SPACE TO DET-2.
  10133. 034900     WRITE PRINT-REC FROM HDR-1
  10134. 035000         AFTER 1 LINE.
  10135. 035100     WRITE PRINT-REC FROM HDR-3 AFTER 2 LINES.
  10136. 035200     WRITE PRINT-REC FROM HDR-5
  10137. 035300         AFTER 1 LINE.
  10138. 035400 016-EXIT.
  10139. 035500     EXIT.
  10140. 035600 017-CONTINUE.
  10141. 035700     MOVE SPACE TO HOLD-PLANTS PLANT-TAB.
  10142. 035800     GO TO 040-V7-SORT.
  10143. 035900 020-BUILD-W7 SECTION.
  10144. 036000 020-OPEN.
  10145. 036100     OPEN INPUT FILE-V7.
  10146. 036200 020-READ.
  10147. 036300     READ FILE-V7 AT END
  10148. 036400         GO TO 020-EXIT.
  10149. 036500     MOVE SPACE TO SORT-THREE.
  10150. 036600     MOVE 1 TO S-NUM-W7.
  10151. 036700     MOVE SDRP-V7 TO SDRP-W7.
  10152. 036800     MOVE PLANT-SYMBOL-V7 TO PLANT-SYMBOL-W7.
  10153. 036900     MOVE RCD-V7 TO DATA-W7.
  10154. 037000     RELEASE SORT-THREE.
  10155. 037100     MOVE ZERO TO SUB-W7.
  10156. 037200 020-LP.
  10157. 037300     IF SUB-W7 = 8
  10158. 037400         GO TO 020-READ.
  10159. 037500     ADD 1 TO SUB-W7.
  10160. 037600     IF PLANT-V7 (SUB-W7) = SPACE
  10161. 037700         GO TO 020-READ.
  10162. 037800     MOVE SPACE TO SORT-THREE.
  10163. 037900     MOVE 2 TO S-NUM-W7.
  10164. 038000     MOVE SDRP-V7 TO SDRP-W7.
  10165. 038100     MOVE RCD-V7 TO DATA-W7.
  10166. 038200     MOVE PLANT-V7 (SUB-W7) TO PLANT-SYMBOL-W7.
  10167. 038300     MOVE SUB-W7 TO AST-W7.
  10168. 038400     RELEASE SORT-THREE.
  10169. 038500     GO TO 020-LP.
  10170. 038600 020-EXIT.
  10171. 038700     EXIT.
  10172. 038800 030-DUPE-CHK SECTION.
  10173. 038900 030-RTN.
  10174. 039000     RETURN SORT-FILE AT END
  10175. 039100         GO TO 030-EXIT.
  10176. 039200     MOVE SORT-THREE TO SORT-HOLD-W7.
  10177. 039300 030-RTN2.
  10178. 039400     RETURN SORT-FILE AT END
  10179. 039500        GO TO 030-EXIT.
  10180. 039600     IF SORT-KEY-W7 NOT = SORT-KEY-HOLD-W7
  10181. 039700         MOVE SORT-THREE TO SORT-HOLD-W7
  10182. 039800         GO TO 030-RTN2.
  10183. 039900     IF (S-NUM-HOLD-W7 = S-NUM-W7) AND
  10184. 040000         (S-NUM-HOLD-W7 = 1)
  10185. 040100         GO TO 030-RTN2.
  10186. 040200     ADD 1 TO W7-CNT.
  10187. 040300     IF LINE-CNT-2 > 50
  10188. 040400         PERFORM 000-OFLO THRU 000-EXIT.
  10189. 040500     MOVE "*******" TO AST (AST-W7).
  10190. 040600     MOVE DATA-HOLD-W7 TO DET-2.
  10191. 040700     WRITE PRINT-REC-2 FROM DET-2 AFTER 1 LINE.
  10192. 040800     MOVE DATA-W7 TO DET-2.
  10193. 040900     WRITE PRINT-REC-2 FROM DET-2 AFTER 1 LINE.
  10194. 041000     MOVE AST-LINE TO DET-2.
  10195. 041100     WRITE PRINT-REC-2 FROM DET-2 AFTER 1 LINE.
  10196. 041200     MOVE SPACE TO AST-LINE.
  10197. 041300     MOVE SPACE TO DET-2.
  10198. 041400     WRITE PRINT-REC-2 FROM DET-2 AFTER 1 LINE.
  10199. 041500     ADD 4 TO LINE-CNT-2.
  10200. 041600     GO TO 030-RTN2.
  10201. 041700 030-EXIT.
  10202. 041800     EXIT.
  10203. 041900 040-V7-SORT SECTION.
  10204. 042000 045-SORT.
  10205. 042100     SORT SORT-FILE ON ASCENDING KEY SDRP-S7,
  10206. 042200         PLANT-SYM-S7
  10207. 042300         USING FILE-V7
  10208. 042400         GIVING FILE-V7.
  10209. 042500 050-V6-SORT SECTION.
  10210. 042600 055-SORT-V6.
  10211. 042700     SORT SORT-FILE ON ASCENDING KEY SORT-KEY
  10212. 042800         INPUT PROCEDURE 065-BUILD-V6
  10213. 042900         OUTPUT PROCEDURE 200-OUTPUT.
  10214. 043000     IF CNT-11 = ZERO
  10215. 043100       DISPLAY " ALL PLANTS WERE VERIFIED AGAINST THE DATA BASE"
  10216. 043200         DISPLAY "    INCLUDING HAVING A PROPER PLANT TYPE."   .
  10217. 043300     IF CNT-9 = ZERO
  10218. 043400         DISPLAY " ALL V7 SPECIES RECORDS MATCHED.".
  10219. 043500*    DISPLAY DIS-CNTS.
  10220. 043600     FINISH DIC-DE.
  10221. 043700     CLOSE PRINT-FILE.
  10222. 043800     CLOSE PRINT-FILE-2
  10223. 043900 060-PASS-SORT SECTION.
  10224. 044000 062-SORT-VERB.
  10225. 044100     SORT SORT-FILE
  10226. 044200             ASCENDING KEY SR-KEY
  10227. 044300             INPUT PROCEDURE 800-INPUT
  10228. 044400             OUTPUT PROCEDURE 900-OUTPUT.
  10229. 044500 064-END.
  10230. 044600     CLOSE ADW-FCTR-FILE.
  10231. 044700     DISPLAY " NEW V6 RECORDS OUTPUT= " CNT-14.
  10232. 044800     DISPLAY " NEW VP RECORDS OUTPUT= " CNT-15.
  10233. 044900     DISPLAY " V6 RECORDS BYPASSED= " CNT-12.
  10234. 045000     DISPLAY " VP RECORDS BYPASSED= " CNT-13.
  10235. 045100     STOP RUN.
  10236. 045200 065-BUILD-V6 SECTION.
  10237. 045300 070-OPEN.
  10238. 045400     OPEN INPUT FILE-V6FUP.
  10239. 045500 075-READ.
  10240. 045600     READ FILE-V6FUP AT END
  10241. 045700         GO TO 100-CLOSE.
  10242. 045800     IF FORM-CODE = "VU" OR "VF"
  10243. 045900         GO TO 075-READ.
  10244. 046000     MOVE SDRP-V6 TO SDRP-S.
  10245. 046100     MOVE PLANT-SYMBOL-V6 TO PLANT-SYMBOL-S.
  10246. 046200     MOVE ZERO TO S-NUM.
  10247. 046300     IF FORM-CODE = "VP"
  10248. 046400         ADD 1 TO CNT-7
  10249. 046500         MOVE "3" TO S-NUM.
  10250. 046600     IF FORM-CODE = "V6"
  10251. 046700         ADD 1 TO CNT-8
  10252. 046800         MOVE "4" TO S-NUM.
  10253. 046900     MOVE V6FUP-REC TO BUILD-SORT.
  10254. 047000     MOVE SORT-BUILD TO DATA-S.
  10255. 047100     ADD 1 TO CNT-5.
  10256. 047200     RELEASE SORT-RCD.
  10257. 047300     GO TO 075-READ.
  10258. 047400 100-CLOSE.
  10259. 047500     CLOSE FILE-V6FUP.
  10260. 047600 200-OUTPUT SECTION.
  10261. 047700 210-OPEN.
  10262. 047800     MOVE SPACE TO V7-CNTL V6-CNTL.
  10263. 047900     OPEN OUTPUT ADW-FCTR-FILE.
  10264. 048000     READY DIC-DE.
  10265. 048100     OPEN INPUT FILE-V7.
  10266. 048200     WRITE PRINT-REC-2 FROM P-SPACE BEFORE PAGE.
  10267. 048300     MOVE 5 TO LINE-CNT-2.
  10268. 048400     ADD 1 TO PG-CNT-2.
  10269. 048500     MOVE PG-CNT-2 TO HDR-PG.
  10270. 048600     MOVE SPACE TO DET-2.
  10271. 048700     WRITE PRINT-REC-2 FROM HDR-1
  10272. 048800         AFTER 1 LINE.
  10273. 048900     MOVE "  (INVALID SPECIES)  " TO RMK-HDR-2B.
  10274. 049000     WRITE PRINT-REC-2 FROM HDR-2 AFTER 2 LINES.
  10275. 049100     WRITE PRINT-REC-2 FROM HDR-5
  10276. 049200         AFTER 1 LINE.
  10277. 049300 220-RETURN.
  10278. 049400     IF (V6-CNTL = V7-CNTL) AND (V7-CNTL = HIGH-VALUE)
  10279. 049500         GO TO 700-CLOSE.
  10280. 049600     IF V6-CNTL = HIGH-VALUE AND (FIRST-SW = 0)
  10281. 049700         GO TO 410-CONTROL.
  10282. 049800     RETURN SORT-FILE AT END
  10283. 049900         MOVE ZERO TO SUB-V7
  10284. 050000         MOVE HIGH-VALUE TO SDRP-HLD PLANT-SYMBOL-HLD
  10285. 050100         GO TO 410-CONTROL.
  10286. 050200     ADD 1 TO CNT-1.
  10287. 050300     IF (SORT-KEY = SORT-KEY-DUPE)
  10288. 050400         DISPLAY "DUPE= " DATA-S
  10289. 050500         GO TO 220-RETURN.
  10290. 050600     IF S-NUM = "3"
  10291. 050700         MOVE SORT-KEY TO SORT-KEY-DUPE.
  10292. 050800     MOVE DATA-S TO SORT-BUILD.
  10293. 050900     MOVE BUILD-SORT TO ADW-FCTR-REC.
  10294. 051000     IF REC-TYP-V6P = "V6" OR "VP"
  10295. 051100         MOVE "B" TO ACT-V6P.
  10296. 051200     WRITE ADW-FCTR-REC.
  10297. 051300     ADD 1 TO CNT-6.
  10298. 051400     MOVE SDRP-S TO SDRP-HLD.
  10299. 051500     MOVE PLANT-SYMBOL-S TO PLANT-SYMBOL-HLD.
  10300. 051600     IF V6-CNTL = V7-CNTL-HLD
  10301. 051700         GO TO 430-RESET-SUBS.
  10302. 051800     MOVE ZERO TO SUB SUB-V7.
  10303. 051900     MOVE SPACE TO HOLD-PLANTS PLANT-TAB.
  10304. 052000     IF FIRST-SW = 1 MOVE ZERO TO FIRST-SW GO TO 400-READ-V7.
  10305. 052100     ADD 1 TO CNT-10.
  10306. 052200     IF V6-CNTL = V7-CNTL
  10307. 052300         GO TO 410-CONTROL .
  10308. 052400     IF V6-CNTL < V7-CNTL
  10309. 052500         GO TO 220-RETURN.
  10310. 052600 310-DISPLAY.
  10311. 052700     MOVE RCD-V7 TO DET-1.
  10312. 052800     IF LINE-CNT > 50
  10313. 052900         PERFORM 016-OFLO THRU 016-EXIT.
  10314. 053000     WRITE PRINT-REC FROM DET-1 AFTER 1 LINE.
  10315. 053100     MOVE SPACE TO AST-LINE.
  10316. 053200     MOVE "*******" TO AST-P.
  10317. 053300     WRITE PRINT-REC FROM AST-LINE AFTER 2 LINES.
  10318. 053400     ADD 3 TO LINE-CNT.
  10319. 053500     ADD 1 TO CNT-9.
  10320. 053600 320-ERR-CHK.
  10321. 053700     IF ERR-SW = 1
  10322. 053800         ADD 1 TO CNT-11
  10323. 053900         PERFORM 620-PRINT THRU 620-EXIT.
  10324. 054000 400-READ-V7.
  10325. 054100     IF V7-CNTL = HIGH-VALUE AND (FIRST-SW = 0)
  10326. 054200         GO TO 410-CONTROL.
  10327. 054300     READ FILE-V7 AT END
  10328. 054400         MOVE HIGH-VALUE TO SDRP-H PLANT-SYMBOL-H
  10329. 054500         GO TO 420-CHK-PLANTS.
  10330. 054600     PERFORM 600-DB-PLANT THRU 600-EXIT.
  10331. 054700     ADD 1 TO CNT-3.
  10332. 054800     MOVE SDRP-V7 TO SDRP-H.
  10333. 054900     MOVE PLANT-SYMBOL-V7 TO PLANT-SYMBOL-H.
  10334. 055000 410-CONTROL.
  10335. 055100     IF (V6-CNTL = V7-CNTL) AND (V7-CNTL = HIGH-VALUE)
  10336. 055200         GO TO 700-CLOSE.
  10337. 055300     IF V6-CNTL = V7-CNTL
  10338. 055400         ADD 1 TO SUB-V7
  10339. 055500         MOVE NEW-PLANT TO PLANT-H (SUB-V7)
  10340. 055600         MOVE HOLD-TYPES TO TYPE-H (SUB-V7)
  10341. 055700         GO TO 320-ERR-CHK.
  10342. 055800     IF V6-CNTL > V7-CNTL
  10343. 055900         GO TO 310-DISPLAY.
  10344. 056000 420-CHK-PLANTS.
  10345. 056100     IF SUB-V7 = ZERO GO TO 220-RETURN.
  10346. 056200 430-RESET-SUBS.
  10347. 056300     MOVE ZERO TO SUB SUB-V7.
  10348. 056400     MOVE V6-CNTL TO V7-CNTL-HLD.
  10349. 056500 500-BUILD-OUTPUT.
  10350. 056600     ADD 1 TO SUB-V7.
  10351. 056700     IF SUB-V7 = 41 GO TO 220-RETURN.
  10352. 056800     IF PLANT-H (SUB-V7) = SPACE GO TO 220-RETURN.
  10353. 056900     MOVE PLANT-H (SUB-V7) TO HOLD-PLANTS.
  10354. 057000     MOVE TYPE-H (SUB-V7) TO WORK-TYPES.
  10355. 057100 510-LOOP.
  10356. 057200     ADD 1 TO SUB.
  10357. 057300     IF SUB = 9
  10358. 057400       MOVE ZERO TO SUB
  10359. 057500         GO TO 500-BUILD-OUTPUT.
  10360. 057600     IF HLD-PLTS (SUB) = SPACE
  10361. 057700         GO TO 510-LOOP.
  10362. 057800     MOVE DATA-S TO SORT-BUILD.
  10363. 057900     MOVE BUILD-SORT TO ADW-FCTR-REC.
  10364. 058000     MOVE HLD-PLTS (SUB) TO PLANT-SYM-V6P.
  10365. 058100     IF REC-TYP-V6P = "V6"
  10366. 058200         MOVE WRK-TYPS (SUB) TO PLANT-TYP-V6
  10367. 058300         ELSE MOVE WRK-TYPS (SUB) TO PLANT-TYP-VP.
  10368. 058400     MOVE "A" TO ACT-V6P.
  10369. 058500     WRITE ADW-FCTR-REC.
  10370. 058600     ADD 1 TO CNT-4.
  10371. 058700     GO TO 510-LOOP.
  10372. 058800 600-DB-PLANT.
  10373. 058900     MOVE ZERO TO SUB.
  10374. 059000     MOVE SPACE TO HOLD-TYPES.
  10375. 059100 601-LOOP.
  10376. 059200     ADD 1 TO SUB.
  10377. 059300     IF SUB = 9
  10378. 059400         GO TO 600-EXIT.
  10379. 059500     IF PLANT-V7 (SUB) = SPACE
  10380. 059600         GO TO 601-LOOP.
  10381. 059700     MOVE PLANT-V7 (SUB) TO HLD-PLANT-CD.
  10382. 059800     PERFORM 610-DB-PLANT THRU 610-EXIT.
  10383. 059900     IF ERR-FLG = 1
  10384. 060000         MOVE 1 TO ERR-SW
  10385. 060100         MOVE "*******" TO PLT-AST (SUB).
  10386. 060200     IF ERR-FLG = 2
  10387. 060300         MOVE 1 TO ERR-SW
  10388. 060400         MOVE "****** " TO PLT-AST (SUB).
  10389. 060500     GO TO 601-LOOP.
  10390. 060600 600-EXIT.
  10391. 060700     EXIT.
  10392. 060800 610-DB-PLANT.
  10393. 060900     MOVE ZERO TO ERR-FLG.
  10394. 061000     MOVE HLD-PLANT-CD TO DE-CD-8822-DEC.
  10395. 061100     MOVE 2646 TO DE-NO-8801-DEC.
  10396. 061200     FIND ANY CODE-DEC.
  10397. 061300     MOVE DB-STATUS TO DATA-BASE-STATUS.
  10398. 061400     IF NOT OK
  10399. 061500         MOVE 1 TO ERR-FLG
  10400. 061600         GO TO 610-EXIT.
  10401. 061700     GET CODE-DEC.
  10402. 061800     MOVE DB-STATUS TO DATA-BASE-STATUS.
  10403. 061900     IF NOT OK
  10404. 062000         MOVE 1 TO ERR-FLG
  10405. 062100         GO TO 610-EXIT.
  10406. 062200     MOVE CODE-DEC TO CODE-DEC-H.
  10407. 062300     IF PLANT-TYP-H NOT = "F" AND "G" AND "T" AND "S"
  10408. 062400         MOVE 2 TO ERR-FLG
  10409. 062500         GO TO 610-EXIT.
  10410. 062600     MOVE PLANT-TYP-H TO HLD-TYPS (SUB).
  10411. 062700 610-EXIT.
  10412. 062800     EXIT.
  10413. 062900 620-PRINT.
  10414. 063000     MOVE 0 TO ERR-SW.
  10415. 063100     IF LINE-CNT-2 > 50
  10416. 063200         MOVE 5 TO LINE-CNT-2
  10417. 063300         ADD 1 TO PG-CNT-2
  10418. 063400         MOVE PG-CNT-2 TO HDR-PG
  10419. 063500         WRITE PRINT-REC-2 FROM P-SPACE BEFORE PAGE
  10420. 063600         WRITE PRINT-REC-2 FROM HDR-1
  10421. 063700         AFTER 1 LINE
  10422. 063800         WRITE PRINT-REC-2 FROM HDR-2 AFTER 2 LINES
  10423. 063900         WRITE PRINT-REC-2 FROM HDR-5
  10424. 064000         AFTER 1 LINE.
  10425. 064100     MOVE RCD-V7 TO DET-1.
  10426. 064200     WRITE PRINT-REC-2 FROM DET-1
  10427. 064300         AFTER 1 LINE.
  10428. 064400     WRITE PRINT-REC-2 FROM DET-2 AFTER 2 LINES.
  10429. 064500     MOVE SPACE TO DET-2.
  10430. 064600     ADD 3 TO LINE-CNT-2.
  10431. 064700 620-EXIT.
  10432. 064800     EXIT.
  10433. 064900 700-CLOSE.
  10434. 065000     CLOSE FILE-V7, ADW-FCTR-FILE.
  10435. 065100 800-INPUT SECTION.
  10436. 065200 810-OPEN.
  10437. 065300     OPEN INPUT ADW-FCTR-FILE.
  10438. 065400 820-READ.
  10439. 065500     READ ADW-FCTR-FILE AT END
  10440. 065600         GO TO 840-EXIT.
  10441. 065700     MOVE SPACE TO SORT-FOUR.
  10442. 065800     MOVE ADW-FCTR-REC TO SR-DATA.
  10443. 065900     MOVE SDRP-V6P TO SDRP-SR.
  10444. 066000     MOVE REC-TYP-V6P TO REC-TYP-SR.
  10445. 066100     MOVE PLANT-SYM-V6P TO PLT-SR.
  10446. 066200     MOVE ACT-V6P TO A-B-CD-SR.
  10447. 066300     IF REC-TYP-V6P = "V6"
  10448. 066400         MOVE PLANT-TYP-V6 TO PLANT-TYP-H
  10449. 066500         MOVE PHENO-V6P TO PHENO-SR.
  10450. 066600     IF REC-TYP-V6P = "VP"
  10451. 066700         MOVE PLANT-TYP-VP TO PLANT-TYP-H
  10452. 066800         MOVE SPACE TO PHENO-SR.
  10453. 066900     IF PLANT-TYP-H = "G" MOVE "1" TO PLT-TYP-SR.
  10454. 067000     IF PLANT-TYP-H = "F" MOVE "2" TO PLT-TYP-SR.
  10455. 067100     IF PLANT-TYP-H = "S" OR "T" MOVE "3" TO PLT-TYP-SR.
  10456. 067200     RELEASE SORT-FOUR.
  10457. 067300     ADD 1 TO CNT-16.
  10458. 067400     GO TO 820-READ.
  10459. 067500 840-EXIT.
  10460. 067600     EXIT.
  10461. 067700 900-OUTPUT SECTION.
  10462. 067800 910-OPEN.
  10463. 067900     CLOSE ADW-FCTR-FILE.
  10464. 068000     OPEN OUTPUT ADW-FCTR-FILE.
  10465. 068100 920-RETURN.
  10466. 068200     RETURN SORT-FILE AT END
  10467. 068300         GO TO 970-EXIT.
  10468. 068400     MOVE SR-DATA TO ADW-FCTR-REC.
  10469. 068500     IF RTN-SW = ZERO
  10470. 068600         MOVE 1 TO RTN-SW
  10471. 068700         MOVE SDRP-SR TO SDRP-H.
  10472. 068800     IF (A-B-CD-SR = "A") AND (REC-TYP-SR = "V6")
  10473. 068900         MOVE PLT-SR TO PLT-BY-V6
  10474. 069000         MOVE PHENO-SR TO PHENO-BY-V6.
  10475. 069100     IF (A-B-CD-SR = "A") AND (REC-TYP-SR = "VP")
  10476. 069200         MOVE PLT-SR TO PLT-BY-VP
  10477. 069300         MOVE PHENO-SR TO PHENO-BY-VP.
  10478. 069400     IF (SDRP-SR NOT = SDRP-H)
  10479. 069500         MOVE SDRP-SR TO SDRP-H
  10480. 069600         GO TO 950-WRITE.
  10481. 069700     IF (A-B-CD-SR = "B") AND (REC-TYP-SR = "V6")
  10482. 069800         AND (PLT-PHENO-SR = V6-BYPASS-HLD)
  10483. 069900             ADD 1 TO CNT-12
  10484. 070000            GO TO 960-CK-DISP.
  10485. 070100     IF (A-B-CD-SR = "B") AND (REC-TYP-SR = "VP")
  10486. 070200         AND (PLT-PHENO-SR = VP-BYPASS-HLD)
  10487. 070300             ADD 1 TO CNT-13
  10488. 070400            GO TO 960-CK-DISP.
  10489. 070500 950-WRITE.
  10490. 070600     IF REC-TYP-V6P = "VP"
  10491. 070700         ADD 1 TO CNT-15.
  10492. 070800     IF REC-TYP-V6P = "V6"
  10493. 070900         ADD 1 TO CNT-14.
  10494. 071000     WRITE ADW-FCTR-REC.
  10495. 071100     GO TO 920-RETURN.
  10496. 071200 960-CK-DISP.
  10497. 071300     IF (FIRST-BY-SW = ZERO)
  10498. 071400         MOVE 1 TO FIRST-BY-SW
  10499. 071500        DISPLAY " "
  10500. 071600        DISPLAY BY-MSG
  10501. 071700        DISPLAY " "
  10502. 071800         DISPLAY BY-HDR
  10503. 071900         DISPLAY " ".
  10504. 072000     IF PLANT-DISP NOT = PLT-SR
  10505. 072100        MOVE PLT-SR TO PLANT-DISP
  10506. 072200         MOVE ST-SR TO ST-BY
  10507. 072300         MOVE DS-SR TO DS-BY
  10508. 072400         MOVE RA-SR TO RA-BY
  10509. 072500         MOVE PU-SR TO PU-BY
  10510. 072600         MOVE PLT-SR TO PLT-BY
  10511. 072700         MOVE REC-TYP-SR TO REC-BY
  10512. 072800         DISPLAY BY-DISP.
  10513. 072900     GO TO 920-RETURN.
  10514. 073000 970-EXIT.
  10515. 073100     EXIT.
  10516. 073200 999-DUMMY SECTION.
  10517. 073300 999-EXIT.
  10518. 073400     EXIT.
  10519. 000000*-----------------------------------------------------------------
  10520. 000100 IDENTIFICATION DIVISION.
  10521. 000200 PROGRAM-ID. ES130M.
  10522. 000300*        CREATES SPECIES ADJUSTMENT FACTOR RECORD (SEE REMARKS)
  10523. 000400*
  10524. 000500 AUTHOR. RON BAKER.
  10525. 000600*REMARKS.  CALCULATES PERCENT PRODUCTION/ADJUSTMENT
  10526. 000700*          FACTOR BY PHENOLOGY STAGE & STORES SPEC-ADJ-FCTR-
  10527. 000800*          REC-PSA RECORD.  INPUT IS ES127MD1.
  10528. 000900*          CALCULATIONS ARE ACCORDING TO P030 OF
  10529. 001000*      ESI USERS GUIDE.
  10530. 001100*           ALL PHRASES WITH "*" ON COL. 7 ARE USED FOR DEBUGGING.
  10531. 001200*
  10532. 001300 DATE-WRITTEN.   09/13/79.
  10533. 001400 DATE-COMPILED.
  10534. 001500 ENVIRONMENT DIVISION.
  10535. 001600 CONFIGURATION SECTION.
  10536. 001700 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  10537. 001800 OBJECT-COMPUTER.  LEVEL-66-ASCII.
  10538. 001900 INPUT-OUTPUT SECTION.
  10539. 002000 FILE-CONTROL.
  10540. 002100     SELECT FILE-I1-I2          ASSIGN TO D1-D2
  10541. 002200         ORGANIZATION IS INDEXED
  10542. 002300         ACCESS MODE IS DYNAMIC
  10543. 002400         RECORD KEY IS INDEX-KEY
  10544. 002500         FILE STATUS IS FILE-STATUS.
  10545. 002600     SELECT FILE-D1          ASSIGN TO I1
  10546. 002700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  10547. 002800     SELECT FILE-P1          ASSIGN TO P1
  10548. 002900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  10549. 003000     SELECT  SORT-WORK ASSIGN Z1.
  10550. 003100 DATA DIVISION.
  10551. 003200 FILE SECTION.
  10552. 003300 FD  FILE-D1
  10553. 003400     CODE-SET IS GBCD
  10554. 003500     LABEL RECORDS ARE STANDARD
  10555. 003600     DATA RECORD IS FDR-D1.
  10556. 003700 01  FDR-D1     PIC X(66).
  10557. 003800 FD  FILE-I1-I2
  10558. 003900
  10559. 004000     LABEL RECORDS ARE STANDARD
  10560. 004100     BLOCK CONTAINS 8960 CHARACTERS
  10561. 004200     RECORD CONTAINS 72 CHARACTERS
  10562. 004300     DATA RECORD IS FDR-I1-I2.
  10563. 004400 01  FDR-I1-I2.
  10564. 004500     03  INDEX-KEY.
  10565. 004600         05  SDRP-I1-I2     PIC X(8).
  10566. 004700         05  PLANT-TYP-I1-I2  PIC 9.
  10567. 004800         05  PLANT-CD-I1-I2   PIC X(7).
  10568. 004900     03  DATA-I1-I2    PIC X(56).
  10569. 005000 SD  SORT-WORK
  10570. 005100     DATA RECORD IS SORT-RCD.
  10571. 005200 01  SORT-RCD.
  10572. 005300     02  SR-KEY.
  10573. 005400         03  SDRP-SR   PIC X(8).
  10574. 005500         03  PLT-TYP-SR   PIC X.
  10575. 005600         03  PLT-PHENO-SR.
  10576. 005700             05  PLT-SR   PIC X(7).
  10577. 005800             05  PHENO-SR   PIC X.
  10578. 005900         03  A-B-CD-SR  PIC X.
  10579. 006000         03  REC-TYP-SR   PIC XXXX.
  10580. 006100     02  SR-DATA     PIC X(66).
  10581. 006200 FD  FILE-P1
  10582. 006300     CODE-SET IS GBCD
  10583. 006400     LABEL RECORDS ARE STANDARD
  10584. 006500     DATA RECORD IS FDR-P1.
  10585. 006600 01  FDR-P1       PIC X(132).
  10586. 006700 WORKING-STORAGE SECTION.
  10587. 006800 01  FILE-STATUS.
  10588. 006900     03  MAJOR-STATUS   PIC X.
  10589. 007000     03  MINOR-STATUS   PIC X.
  10590. 007100 77  I            PIC 9(2) VALUE ZERO.
  10591. 007200 77  CNT-1     PIC 9(6)  VALUE ZERO.
  10592. 007300 77  CNT-2     PIC 9(6)  VALUE ZERO.
  10593. 007400 77 DDD    PIC Z,ZZZ,ZZZ.ZZZZZZ.
  10594. 007500 77 EEE    PIC Z,ZZZ,ZZZ.ZZZZZZ.
  10595. 007600 77 FFF    PIC Z,ZZZ,ZZZ.ZZZZZZ.
  10596. 007700 77 GGG    PIC Z,ZZZ,ZZZ.ZZZZZZ.
  10597. 007800 77 HHH    PIC Z,ZZZ,ZZZ.ZZZZZZ.
  10598. 007900 77  MMTOT    PIC 9(5)V9(6).
  10599. 008000 77  MMQTR    PIC 9(5)V9(6).
  10600. 008100 77  QTRPIE    PIC 9(5)V9(6).
  10601. 008200 77  MAX-GRAMS    PIC 9(7)V9(6) VALUE ZERO.
  10602. 008300 77  GRAMS-PER-FT  PIC 9(7)V9(6)  VALUE ZERO.
  10603. 008400 77  MIN-TEMP    PIC 9(5)V9(4).
  10604. 008500 77  MAX-TEMP    PIC 9(5)V9(4).
  10605. 008600 77  SQ-FT-TEMP   PIC 9(5)V9(4) VALUE ZERO.
  10606. 008700 77  LIN-CHK  PIC 99  COMP-4.
  10607. 008800 77  LIN-CNT  PIC 99  COMP-4.
  10608. 008900 77  PHNO-CNT  PIC 99  COMP-4.
  10609. 009000 77  PAG-CNT  PIC 999  COMP-4.
  10610. 009100 77  VP-PLT-CD-HLD   PIC X(7)   VALUE SPACE.
  10611. 009200 77  PUF-CNT  PIC 999  COMP-4.
  10612. 009300 77  AUF-CNT  PIC 999  COMP-4.
  10613. 009400 77  ADW-HLD    PIC 9(4)V99   VALUE ZERO.
  10614. 009500 77  PCT-HLD    PIC 999   VALUE ZERO.
  10615. 009600 77  PHNO-STG-HLD  PIC 9 VALUE ZERO.
  10616. 009700 77  REC-CNT-PHNO-STG    PIC 9999   VALUE ZERO.
  10617. 009800 77  REC-CNT-PLANT-TOT    PIC 9999   VALUE ZERO.
  10618. 009900 77  PCT-TOT-HLD    PIC 9(5)   VALUE ZERO.
  10619. 010000 77  PCT-TOT-PHNO-STG    PIC 9(5)   VALUE ZERO.
  10620. 010100 77  PNNO-SW    PIC 9 VALUE ZERO.
  10621. 010200 77  DISPLAY-SW  PIC 9   VALUE 0 COMP-4.
  10622. 010300 77  FIRST-SW  PIC 9   VALUE 1 COMP-4.
  10623. 010400 77  SUB   PIC 99 COMP-4.
  10624. 010500 77  PHNO-SUB  PIC 9  COMP-4.
  10625. 010600 01  VP-BYPASS-HLD.
  10626. 010700     03  PLT-BY-VP   PIC X(7).
  10627. 010800     03  PHENO-BY-VP PIC X.
  10628. 010900 01  V6-BYPASS-HLD.
  10629. 011000     03  PLT-BY-V6   PIC X(7).
  10630. 011100     03  PHENO-BY-V6 PIC X.
  10631. 011200******************************************************************
  10632. 011300*  "VP" PHENOLOGY ADJUSTMENT DATA.
  10633. 011500 01  REC-VP-X.
  10634. 011600     05  KEY-VP-X.
  10635. 011700         10  DIC-VP-X.
  10636. 011800             15  REC-TYP-3529-VP-X                PIC X(2).
  10637. 011900             15  FMT-NUM-3576-VP-X                PIC X(1).
  10638. 012000             15  FMT-CD-3579-VP-X                 PIC X(1).
  10639. 012100         10  BLM-ADM-U-0003-VP-X.
  10640. 012200             15  BLM-ADM-U-0003-ST-VP-X           PIC X(2).
  10641. 012300             15  BLM-ADM-U-0003-DIST-VP-X         PIC X(2).
  10642. 012400             15  BLM-ADM-U-0003-RA-VP-X           PIC X(2).
  10643. 012500             15  BLM-ADM-U-0003-PLU-VP-X          PIC X(2).
  10644. 012600         10  DATA-DATE-6618-VP-X.
  10645. 012700             15  DATA-DATE-6618-YY-VP-X           PIC X(2).
  10646. 012800             15  DATA-DATE-6618-MM-VP-X           PIC X(2).
  10647. 012900             15  DATA-DATE-6618-DD-VP-X           PIC X(2).
  10648. 013000         10  ACTN-CD-7350-VP-X                    PIC X(1).
  10649. 013100         10  LIN-NUM-3578-VP-X                    PIC X(4).
  10650. 013200*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  10651. 013300     05  PLANT-CD-2646-VP-X                       PIC X(7).
  10652. 013400     05  PHNO-GP-VP-X     PIC X(32).
  10653. 013500     05  PHNO-ADJ-GP-VP-X REDEFINES PHNO-GP-VP-X.
  10654. 013600         07  PHNO-ADJ-VP-X  OCCURS 8 TIMES.
  10655. 013700             09  PHNO-ADJ-1-VP-X   PIC XX.
  10656. 013800             09  PHNO-ADJ-2-VP-X  PIC XX.
  10657. 013900     05  PHNO-ADJ-FCTR-3545-VP-X REDEFINES PHNO-GP-VP-X
  10658. 014000             OCCURS 8 TIMES     PIC 99V99.
  10659. 014100     05  PLANT-TYP-3590-VP-X    PIC X.
  10660. 014200     05  FILLER                   PIC XXX.
  10661. 014500*  "V6" DRY/GREEN WEIGHT CONVERSION FACTOR DATA.
  10662. 014700 01  REC-V6-X.
  10663. 014800     05  KEY-V6-X.
  10664. 014900         10  DIC-V6-X.
  10665. 015000             15  REC-TYP-3529-V6-X                PIC X(2).
  10666. 015100             15  FMT-NUM-3576-V6-X                PIC X(1).
  10667. 015200             15  FMT-CD-3579-V6-X                 PIC X(1).
  10668. 015300         10  BLM-ADM-U-0003-V6-X.
  10669. 015400             15  BLM-ADM-U-0003-ST-V6-X           PIC X(2).
  10670. 015500             15  BLM-ADM-U-0003-DIST-V6-X         PIC X(2).
  10671. 015600             15  BLM-ADM-U-0003-RA-V6-X           PIC X(2).
  10672. 015700             15  BLM-ADM-U-0003-PLU-V6-X          PIC X(2).
  10673. 015800         10  DATA-DATE-6618-V6-X.
  10674. 015900             15  DATA-DATE-6618-YY-V6-X           PIC X(2).
  10675. 016000             15  DATA-DATE-6618-MM-V6-X           PIC X(2).
  10676. 016100             15  DATA-DATE-6618-DD-V6-X           PIC X(2).
  10677. 016200         10  ACTN-CD-7350-V6-X                    PIC X(1).
  10678. 016300         10  LIN-NUM-3578-V6-X                    PIC X(4).
  10679. 016400*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  10680. 016500     05  PLANT-CD-2646-V6-X                       PIC X(7).
  10681. 016600     05  PHNO-STG-CD-3712-V6-X                    PIC 9(1).
  10682. 016700     05  GRAMS-GRN-WGT-3941-V6-X                  PIC 9(4).
  10683. 016800     05  ADW-PCT-3546-V6-X           PIC 9V99.
  10684. 016900     05  ADW-PCT-V6-X-RD REDEFINES ADW-PCT-3546-V6-X PIC 999.
  10685. 017000     05  GRAMS-DRY-WGT-3942-V6-X                  PIC 9(4).
  10686. 017100     05  GRP-1-V6-X.
  10687. 017200         07  BASAL-DIMS-3533-MIN-V6-X                 PIC 99V99.
  10688. 017300         07  BASAL-DIMS-3533-MAX-V6-X                 PIC 99V99.
  10689. 017400         07  CROWN-DIMS-3534-MIN-V6-X                 PIC 99V9.
  10690. 017500         07  CROWN-DIMS-3534-MAX-V6-X                 PIC 99V9.
  10691. 017600         07  HGT-AVG-3504-V6-X                        PIC 999V9.
  10692. 017700         07  AVG-LDR-LGT-7313-V6-X                    PIC 99V9.
  10693. 017800     05  GRP-1-RD-V6-X REDEFINES GRP-1-V6-X.
  10694. 017900         07  BASAL-DIMS-MIN-V6-X.
  10695. 018000             09  BAD-MIN-1-V6-X   PIC XX.
  10696. 018100             09  BAD-MIN-2-V6-X   PIC XX.
  10697. 018200         07  BASAL-DIMS-MAX-V6-X.
  10698. 018300             09  BAD-MAX-1-V6-X   PIC XX.
  10699. 018400             09  BAD-MAX-2-V6-X   PIC XX.
  10700. 018500         07  CROWN-DIMS-MIN-V6-X.
  10701. 018600             09  CRD-MIN-1-V6-X   PIC XX.
  10702. 018700             09  CRD-MIN-2-V6-X   PIC X.
  10703. 018800         07  CROWN-DIMS-MAX-V6-X.
  10704. 018900             09  CRD-MAX-1-V6-X   PIC XX.
  10705. 019000             09  CRD-MAX-2-V6-X   PIC X.
  10706. 019100         07  HGT-AVG-V6-X.
  10707. 019200             09  HGT-AVG-1-V6-X   PIC XXX.
  10708. 019300             09  HGT-AVG-2-V6-X   PIC X.
  10709. 019400         07  AVG-LDR-V6-X.
  10710. 019500             09  AVG-LDR-1-V6-X   PIC XX.
  10711. 019600             09  AVG-LDR-2-V6-X   PIC X.
  10712. 019700     05  PLANT-TYP-V6-X             PIC X.
  10713. 019800     05  REC-CNT-V6-X     PIC 99.
  10714. 019900******************************************************************
  10715. 020000 01  SPEC-AFR.
  10716. 020100     03  SDRP-AFR          PIC X(8).
  10717. 020200     03  PLANT-TYP-AFR     PIC X.
  10718. 020300     03  PLANT-CD-AFR     PIC X(7).
  10719. 020400     03  ADW-PCT-GP-AFR    PIC X(24).
  10720. 020500     03  ADW-PCT-AFR REDEFINES ADW-PCT-GP-AFR
  10721. 020600         OCCURS 8 TIMES    PIC 999.
  10722. 020700     03  PAF-GP-AFR        PIC X(32).
  10723. 020800     03  PAF-AFR REDEFINES PAF-GP-AFR
  10724. 020900         OCCURS 8 TIMES    PIC 99V99.
  10725. 021000******************************************************************
  10726. 021100 01  HDR-1.
  10727. 021200     05  FILLER  PIC X(24)  VALUE "    PCN: ES140M   AS OF ".
  10728. 021300     05  HDR-DD        PIC XX.
  10729. 021400     05  FILLER        PIC X         VALUE SPACE.
  10730. 021500     05  HDR-MMM       PIC XXX.
  10731. 021600     05  FILLER        PIC X         VALUE SPACE.
  10732. 021700     05  HDR-YR        PIC XX.
  10733. 021800     05  FILLER         PIC X(09)     VALUE SPACES.
  10734. 021900     05  FILLER         PIC X(48)     VALUE
  10735. 022000         "USDI- BUR OF LAND MGT  ECOLOGICAL SITE INVENTORY".
  10736. 022100     05  FILLER         PIC X(31)     VALUE SPACES.
  10737. 022200     05  FILLER         PIC X(5)      VALUE "PAGE:".
  10738. 022300     05  HDR-PG         PIC ZZZZZ9.
  10739. 022400 01  HDR-2.
  10740. 022500     05  FILLER        PIC X(17)     VALUE SPACES.
  10741. 022600     05  FILLER        PIC X(8)      VALUE "STATE:  ".
  10742. 022700     05  HDR-ST-NM     PIC X(10).
  10743. 022800     05  FILLER        PIC X(16)     VALUE SPACES.
  10744. 022900     05  FILLER        PIC X(7)      VALUE "DIST:  ".
  10745. 023000     05  HDR-DIST-NM         PIC X(15).
  10746. 023100     05  FILLER        PIC X(5)     VALUE SPACES.
  10747. 023200     05  RMK-HDR-2  PIC X(40)  VALUE SPACE.
  10748. 023300     05  FILLER        PIC X(9)     VALUE SPACES.
  10749. 023400 01  HDR-3    PIC X(132).
  10750. 023500 01  HDR-4    PIC X(132).
  10751. 023600 01  FDR-D1-WK.
  10752. 023700     03  CNTL-D1.
  10753. 023800         05  REC-TYP-D1    PIC XXXX.
  10754. 023900         05  SDRP-D1.
  10755. 024000             07 SDR-D1.
  10756. 024100                 09 SD-D1.
  10757. 024200                     11  ST-D1  PIC XX.
  10758. 024300                 11  DIST-D1 PIC XX.
  10759. 024400                 09  RA-D1   PIC XX.
  10760. 024500             07  PLU-D1    PIC XX.
  10761. 024600         05  DATE-D1   PIC X(6).
  10762. 024700         05  ACTN-D1   PIC X.
  10763. 024800         05  LINE-D1   PIC XXXX.
  10764. 024900         05  PLANT-CD-D1   PIC X(7).
  10765. 025000         05  PHENO-D1   PIC X.
  10766. 025100     03  DATA-D1.
  10767. 025200         05  FILLER    PIC X(31).
  10768. 025300         05  PLANT-TYP-VP-D1  PIC X.
  10769. 025400         05  PLANT-TYP-V6-D1  PIC X.
  10770. 025500         05  REC-CNT-V6-D1     PIC 99.
  10771. 025600 01  CNTL-HLD.
  10772. 025700     03  REC-TYP-HLD PIC XXXX.
  10773. 025800     03  SDRP-HLD.
  10774. 025900         05  SDR-HLD.
  10775. 026000             07  SD-HLD.
  10776. 026100                 09  ST-HLD       PIC XX.
  10777. 026200                 09  DIST-HLD       PIC XX.
  10778. 026300             07  RA-HLD       PIC XX.
  10779. 026400         05  PLU-HLD        PIC XX.
  10780. 026500     03  DATE-HLD   PIC X(6).
  10781. 026600     03  ACTN-HLD   PIC X.
  10782. 026700     03  LINE-HLD   PIC XXXX.
  10783. 026800     03  PLANT-CD-HLD   PIC X(7).
  10784. 026900     03  PHENO-HLD   PIC X.
  10785. 027000 01 HLD-NAMES.
  10786. 027100     03  FUNC-HLD.
  10787. 027200         05  ST-NM-HLD    PIC X(10).
  10788. 027300         05  FILLER       PIC X(14).
  10789. 027400     03  EXPL-HLD.
  10790. 027500         05  DIST-NM-HLD    PIC X(11).
  10791. 027600         05  FILLER        PIC X.
  10792. 027700         05  RA-NM-HLD     PIC X(12).
  10793. 027800         05  FILLER        PIC X.
  10794. 027900         05  PU-NM-HLD     PIC X(15).
  10795. 028000         05  FILLER        PIC X.
  10796. 028100 01  HOLD-AREA.
  10797. 028200     03  CT-CODE-TABLE-H.
  10798. 028300         05  FILLER  PIC XXXX.
  10799. 028400         05  PLANT-CD-H  PIC X(7).
  10800. 028500         05  FILLER  PIC X(24).
  10801. 028600         05  PLANT-TYP-H  PIC X.
  10802. 028700     03  CT-FUNC-NAM-H.
  10803. 028800         05  DIST-NAM-H  PIC X(15).
  10804. 028900         05  FILLER  PIC X(9).
  10805. 029000     03  HLD-PLANT-CD    PIC X(7).
  10806. 029100     03  HLD-PLANT-TYP    PIC X.
  10807. 029200     03  HLD-ANML-CD  PIC XX.
  10808. 029300     03  DAT-H.
  10809. 029400         05  YER-H  PIC XX.
  10810. 029500         05  MON-H  PIC 99.
  10811. 029600         05  DAY-H  PIC XX.
  10812. 029700     03  DATA-DATE-VP-HLD.
  10813. 029800         05  DATA-YER-VP-HLD  PIC XX.
  10814. 029900         05  DATA-MON-VP-HLD  PIC XX.
  10815. 030000         05  DATA-DAY-VP-HLD  PIC XX.
  10816. 030100     03  D-DATE-CHK.
  10817. 030200         05  D-YER-CHK  PIC XX.
  10818. 030300         05  D-MON-CHK  PIC XX.
  10819. 030400         05  D-DAY-CHK  PIC XX.
  10820. 030500     03  JDAY-H  PIC 9(5).
  10821. 030600     03  JDAY-P0-H  PIC 9(5).
  10822. 030700     03  J9-H  REDEFINES  JDAY-P0-H.
  10823. 030800         05  1ST-2C-JDAY-P0-H  PIC 99.
  10824. 030900         05  LST-3C-JDAY-P0-H  PIC 999.
  10825. 031000     03  CNTS-IGB.
  10826. 031100         05  CNT-VPI    PIC 9(5)   VALUE ZERO.
  10827. 031200         05  FILLER   PIC XX  VALUE SPACE.
  10828. 031300         05  CNT-V6I  PIC 9(5)   VALUE ZERO.
  10829. 031400         05  FILLER   PIC XX  VALUE SPACE.
  10830. 031500         05  CNT-SUM   PIC 9(5)   VALUE ZERO.
  10831. 031600         05  FILLER   PIC XX  VALUE SPACE.
  10832. 031700 01  TABL-AREA.
  10833. 031800     03  MON-V  PIC X(36)  VALUE   "JANFEBMARAPRMAYJUNJULAUGSEPOCT
  10834. 031900-                                  "NOVDEC".
  10835. 032000     03  MON-T  REDEFINES  MON-V  PIC XXX  OCCURS 12 TIMES.
  10836. 032100 01  BASAL-CROWN-AREA-PER-STG.
  10837. 032200       03  RECNT OCCURS 8 TIMES PIC 9(5)V9(4).
  10838. 032300*
  10839. 032400*
  10840. 032500 01  WGT-PER-STG.
  10841. 032600       03  GPF-TOT OCCURS 8 TIMES PIC 9(7)V9(4).
  10842. 032700*
  10843. 032800*
  10844. 032900 01  GRAMS-PER-SQ-FT.
  10845. 033000       03  GRAMS-FT OCCURS 8 TIMES PIC 9(7)V9(4).
  10846. 033100*
  10847. 033200*
  10848. 033300 01  PERCENT-PER-STG.
  10849. 033400       03  PERSENT OCCURS 8 TIMES PIC 9(3)V9(4).
  10850. 033500 01  ADW-PCT-TAB.
  10851. 033600       03  ADW-PCT OCCURS 8 TIMES PIC 9(3).
  10852. 033700*
  10853. 033800*
  10854. 033900 01  FINISHED     PIC X(4).
  10855. 034000       88  DONE        VALUE "    ".
  10856. 034100*
  10857. 034200*
  10858. 034300 01  ADJ-FACTOR.
  10859. 034400       03  ADJ-FAC OCCURS 8 TIMES PIC 99V99.
  10860. 034500*
  10861. 034600*
  10862. 034700 01  V61Z-KEY.
  10863. 034800       03  ADST     PIC X(2).
  10864. 034900       03  DIST     PIC 9(2).
  10865. 035000       03  RA       PIC 9(2).
  10866. 035100       03  PLU      PIC 9(2).
  10867. 035200*
  10868. 035300*
  10869. 035400 01  CROWN.
  10870. 035500       03  CRN1   PIC X(3).
  10871. 035600       03  CRN2 REDEFINES CRN1 PIC 99V9.
  10872. 035700*
  10873. 035800*
  10874. 035900 01  BASAL.
  10875. 036000       03  BSL1    PIC X(4).
  10876. 036100       03  BSL2 REDEFINES BSL1 PIC 99V99.
  10877. 036200*
  10878. 036300 01 P-SPACE    PIC X(132)    VALUE SPACE.
  10879. 036400 PROCEDURE DIVISION.
  10880. 036500 000-HOUSEKEEPING SECTION.
  10881. 036600 000-BEGIN.
  10882. 036700     ACCEPT DAT-H FROM DATE.  ACCEPT JDAY-H FROM DAY.
  10883. 036800     MOVE DAY-H TO HDR-DD.  MOVE MON-T (MON-H) TO HDR-MMM.
  10884. 036900     MOVE YER-H TO HDR-YR.
  10885. 037000     MOVE SPACE TO SPEC-AFR.
  10886. 037100     INITIALIZE BASAL-CROWN-AREA-PER-STG
  10887. 037200         WGT-PER-STG
  10888. 037300          GRAMS-PER-SQ-FT
  10889. 037400          PERCENT-PER-STG
  10890. 037500          I
  10891. 037600          MAX-TEMP
  10892. 037700          MIN-TEMP
  10893. 037800          MAX-GRAMS
  10894. 037900         ADJ-FACTOR
  10895. 038000         ADW-PCT-TAB
  10896. 038100          SQ-FT-TEMP.
  10897. 038200 100-SORT SECTION.
  10898. 038300 110-SORT-VERB.
  10899. 038400     SORT SORT-WORK
  10900. 038500             ASCENDING KEY SR-KEY
  10901. 038600             INPUT PROCEDURE 200-INPUT
  10902. 038700             OUTPUT PROCEDURE 300-OUTPUT.
  10903. 038800 150-END.
  10904. 038900     CLOSE FILE-D1.
  10905. 039000     CLOSE FILE-I1-I2.
  10906. 039100     STOP RUN.
  10907. 039200 200-INPUT SECTION.
  10908. 039300 210-OPEN.
  10909. 039400     OPEN INPUT FILE-D1.
  10910. 039500     OPEN OUTPUT FILE-I1-I2.
  10911. 039600     READ FILE-D1 AT END STOP RUN.
  10912. 039700     MOVE FDR-D1 TO FDR-D1-WK.
  10913. 039800     GO TO 230-BUILD-SORT.
  10914. 039900 210-READ.
  10915. 040000     READ FILE-D1 AT END
  10916. 040100         GO TO 240-EXIT.
  10917. 040200     MOVE FDR-D1 TO FDR-D1-WK.
  10918. 040300     GO TO 230-BUILD-SORT.
  10919. 040400 230-BUILD-SORT.
  10920. 040500     IF REC-TYP-D1 = "VP1D" OR "V61D" NEXT SENTENCE ELSE
  10921. 040600         GO TO 210-READ.
  10922. 040700*    IF PLANT-CD-D1 NOT = "AGSM   " AND "SPGR   "
  10923. 040800*        GO TO 210-READ.
  10924. 040900*    IF PLANT-CD-D1 NOT = "ALTE   "
  10925. 041000*        GO TO 210-READ.
  10926. 041100*    IF PLANT-CD-D1 NOT = "AGSM   "
  10927. 041200*        GO TO 210-READ.
  10928. 041300     MOVE SPACE TO SORT-RCD.
  10929. 041400     MOVE FDR-D1-WK TO SR-DATA.
  10930. 041500     MOVE SDRP-D1 TO SDRP-SR.
  10931. 041600     MOVE REC-TYP-D1 TO REC-TYP-SR.
  10932. 041700     MOVE PLANT-CD-D1 TO PLT-SR.
  10933. 041800     MOVE ACTN-D1 TO A-B-CD-SR.
  10934. 041900     IF REC-TYP-D1 = "V61D"
  10935. 042000         ADD 1 TO CNT-V6I
  10936. 042100         MOVE PLANT-TYP-V6-D1 TO PLANT-TYP-H
  10937. 042200         MOVE PHENO-D1 TO PHENO-SR.
  10938. 042300     IF REC-TYP-D1 = "VP1D"
  10939. 042400         ADD 1 TO CNT-VPI
  10940. 042500         MOVE PLANT-TYP-VP-D1 TO PLANT-TYP-H
  10941. 042600         MOVE SPACE TO PHENO-SR.
  10942. 042700     IF PLANT-TYP-H = "G" MOVE "1" TO PLT-TYP-SR.
  10943. 042800     IF PLANT-TYP-H = "F" MOVE "2" TO PLT-TYP-SR.
  10944. 042900     IF PLANT-TYP-H = "S" OR "T" MOVE "3" TO PLT-TYP-SR.
  10945. 043000     RELEASE SORT-RCD.
  10946. 043100     GO TO 210-READ.
  10947. 043200 240-EXIT.
  10948. 043300     EXIT.
  10949. 043400 300-OUTPUT SECTION.
  10950. 043500 310-RTN-FIRST.
  10951. 043600     RETURN SORT-WORK AT END STOP RUN.
  10952. 043700     ADD 1 TO CNT-1.
  10953. 043800     MOVE SR-DATA TO FDR-D1-WK.
  10954. 043900     MOVE CNTL-D1 TO CNTL-HLD.
  10955. 044000     GO TO 400-PROCESS.
  10956. 044100 320-END-PROC.
  10957. 044200     PERFORM 415-CAL-ADW-PCT THRU 415-EXIT.
  10958. 044300     PERFORM 500-FINAL-CALCS.
  10959. 044400     PERFORM 700-BUILD-SPEC-REC.
  10960. 044500     GO TO 800-EXIT.
  10961. 044600 400-PROCESS.
  10962. 044700     IF DISPLAY-SW = 1
  10963. 044800         DISPLAY FDR-D1-WK.
  10964. 044900*    IF THE KEY OR PLANT CODE CHANGES, CALCULATE & STORE THE
  10965. 045000*         PLANT PREVIOUSLY COLLECTED.
  10966. 045100     IF REC-TYP-SR = "VP1D"
  10967. 045200         MOVE FDR-D1-WK TO REC-VP-X ELSE
  10968. 045300          MOVE FDR-D1-WK TO REC-V6-X.
  10969. 045400     IF (SDRP-SR NOT = SDRP-HLD)
  10970. 045500         AND (FIRST-SW = 0)
  10971. 045600         PERFORM 415-CAL-ADW-PCT THRU 415-EXIT
  10972. 045700         GO TO 430-SUM.
  10973. 045800     IF DISPLAY-SW = 1
  10974. 045900         DISPLAY "SRK= " SR-KEY.
  10975. 046000     IF (A-B-CD-SR = "A") AND (REC-TYP-SR = "V61D")
  10976. 046100         MOVE PLT-SR TO PLT-BY-V6
  10977. 046200         MOVE PHENO-SR TO PHENO-BY-V6.
  10978. 046300     IF (A-B-CD-SR = "A") AND (REC-TYP-SR = "VP1D")
  10979. 046400         MOVE PLT-SR TO PLT-BY-VP
  10980. 046500         MOVE PHENO-SR TO PHENO-BY-VP.
  10981. 046600     IF (A-B-CD-SR = "B") AND (REC-TYP-SR = "V61D")
  10982. 046700         AND (PLT-PHENO-SR = V6-BYPASS-HLD)
  10983. 046800*        DISPLAY "PASS " SR-DATA
  10984. 046900         GO TO 420-RETURN.
  10985. 047000     IF (A-B-CD-SR = "B") AND (REC-TYP-SR = "VP1D")
  10986. 047100         AND (PLT-PHENO-SR = VP-BYPASS-HLD)
  10987. 047200*        DISPLAY "PASS " SR-DATA
  10988. 047300         GO TO 420-RETURN.
  10989. 047400     IF (PLT-SR NOT = PLANT-CD-HLD)
  10990. 047500         AND (FIRST-SW = 0)
  10991. 047600         PERFORM 415-CAL-ADW-PCT THRU 415-EXIT
  10992. 047700         GO TO 430-SUM.
  10993. 047800     IF REC-TYP-SR = "VP1D"
  10994. 047900         MOVE PLANT-TYP-3590-VP-X TO PLANT-TYP-H
  10995. 048000         MOVE PLT-SR TO VP-PLT-CD-HLD
  10996. 048100         MOVE PHNO-GP-VP-X TO ADJ-FACTOR
  10997. 048200         GO TO 420-RETURN.
  10998. 048300     IF (PHENO-SR NOT = PHNO-STG-HLD)
  10999. 048400         AND (FIRST-SW = 0)
  11000. 048500         PERFORM 415-CAL-ADW-PCT THRU 415-EXIT.
  11001. 048600*
  11002. 048700*     CALCULATE THE AIR DRY WEIGHT FOR EACH V6 RECORD.
  11003. 048800*
  11004. 048900     IF GRAMS-DRY-WGT-3942-V6-X = SPACE
  11005. 049000         MOVE ZERO TO GRAMS-DRY-WGT-3942-V6-X.
  11006. 049100     IF (ADW-PCT-3546-V6-X > ZERO) AND
  11007. 049200         (GRAMS-DRY-WGT-3942-V6-X =   ZERO)
  11008. 049300         COMPUTE ADW-HLD ROUNDED = ADW-PCT-3546-V6-X *
  11009. 049400                           GRAMS-GRN-WGT-3941-V6-X
  11010. 049500         MOVE ADW-HLD TO GRAMS-DRY-WGT-3942-V6-X
  11011. 049600         ELSE
  11012. 049700         MOVE GRAMS-DRY-WGT-3942-V6-X TO ADW-HLD.
  11013. 049800     IF REC-CNT-V6-X = SPACE OR ZERO
  11014. 049900         MOVE 01 TO REC-CNT-V6-X.
  11015. 050000     ADD REC-CNT-V6-X TO REC-CNT-PHNO-STG.
  11016. 050100     COMPUTE PCT-TOT-HLD = REC-CNT-V6-X * ADW-PCT-V6-X-RD.
  11017. 050200     ADD PCT-TOT-HLD TO PCT-TOT-PHNO-STG.
  11018. 050300     MOVE ZERO TO FIRST-SW.
  11019. 050400 410-CAL-AREA.
  11020. 050500     MOVE CNTL-D1 TO CNTL-HLD.
  11021. 050600     MOVE PHENO-D1 TO PHNO-STG-HLD.
  11022. 050700*
  11023. 050800*    CALCULATE THE AREA PER PHENO STAGE OF THE INCOMING RECORD.
  11024. 050900*
  11025. 051000*    IF (SDRP-SR = "WY036829") AND (PLT-SR = "ALTE   ")
  11026. 051100*        AND (DISPLAY-SW = ZERO)
  11027. 051200*        MOVE 3 TO DISPLAY-SW.
  11028. 051300     MOVE PLANT-TYP-V6-X TO PLANT-TYP-H.
  11029. 051400     IF PLANT-TYP-V6-X = "G"
  11030. 051500         MOVE BASAL-DIMS-MIN-V6-X TO BSL1
  11031. 051600         MOVE BSL2 TO MIN-TEMP
  11032. 051700         MOVE BASAL-DIMS-MAX-V6-X TO BSL1
  11033. 051800         MOVE BSL2 TO MAX-TEMP
  11034. 051900     ELSE
  11035. 052000         MOVE CROWN-DIMS-MIN-V6-X TO CRN1
  11036. 052100         MOVE CRN2 TO MIN-TEMP
  11037. 052200         MOVE CROWN-DIMS-MAX-V6-X TO CRN1
  11038. 052300         MOVE CRN2 TO MAX-TEMP.
  11039. 052400     IF (PLANT-TYP-V6-X = "G")
  11040. 052500         AND (MIN-TEMP = ZERO)
  11041. 052600         MOVE CROWN-DIMS-MIN-V6-X TO CRN1
  11042. 052700         MOVE CRN2 TO MIN-TEMP
  11043. 052800         MOVE CROWN-DIMS-MAX-V6-X TO CRN1
  11044. 052900         MOVE CRN2 TO MAX-TEMP.
  11045. 053000     IF (PLANT-TYP-V6-X = "F" OR "S" OR "T")
  11046. 053100         AND (MIN-TEMP = ZERO)
  11047. 053200         MOVE BASAL-DIMS-MIN-V6-X TO BSL1
  11048. 053300         MOVE BSL2 TO MIN-TEMP
  11049. 053400         MOVE BASAL-DIMS-MAX-V6-X TO BSL1
  11050. 053500         MOVE BSL2 TO MAX-TEMP.
  11051. 053600     COMPUTE MMTOT ROUNDED = MIN-TEMP * MAX-TEMP.
  11052. 053700     COMPUTE MMQTR ROUNDED = MMTOT  /  4.
  11053. 053800     COMPUTE QTRPIE ROUNDED = MMQTR  *  3.1417.
  11054. 053900     COMPUTE SQ-FT-TEMP ROUNDED = QTRPIE * REC-CNT-V6-X.
  11055. 054000     MOVE MMTOT TO EEE.
  11056. 054100     MOVE MMQTR TO FFF.
  11057. 054200     MOVE QTRPIE TO GGG.
  11058. 054300     MOVE SQ-FT-TEMP TO DDD.
  11059. 054400     IF DISPLAY-SW = 1
  11060. 054500     DISPLAY "SF=" DDD " QP=" GGG " MQ=" FFF " MT=" EEE.
  11061. 054600*    ADD SQ-FT-TEMP TO RECNT (PHNO-STG-CD-3712-V6-X).
  11062. 054700*    ADD ADW-HLD TO
  11063. 054800*        GPF-TOT (PHNO-STG-CD-3712-V6-X).
  11064. 054900     MOVE ZERO TO GRAMS-PER-FT.
  11065. 055000     IF SQ-FT-TEMP NOT = ZERO
  11066. 055100         COMPUTE GRAMS-PER-FT = ADW-HLD / SQ-FT-TEMP
  11067. 055200         ADD 1 TO RECNT (PHNO-STG-CD-3712-V6-X)
  11068. 055300         ADD GRAMS-PER-FT TO GPF-TOT (PHNO-STG-CD-3712-V6-X).
  11069. 055400     IF DISPLAY-SW = 1
  11070. 055500*        MOVE RECNT (PHNO-STG-CD-3712-V6-X) TO DDD
  11071. 055600         MOVE GRAMS-PER-FT TO DDD
  11072. 055700         MOVE GPF-TOT (PHNO-STG-CD-3712-V6-X) TO GGG
  11073. 055800         DISPLAY "GPF" DDD " GRF-TOT=" GGG.
  11074. 055900 420-RETURN.
  11075. 056000     RETURN SORT-WORK AT END
  11076. 056100         GO TO 320-END-PROC.
  11077. 056200     ADD 1 TO CNT-1.
  11078. 056300     MOVE SR-DATA TO FDR-D1-WK.
  11079. 056400     GO TO 400-PROCESS.
  11080. 056500 415-CAL-ADW-PCT.
  11081. 056600     IF PCT-TOT-PHNO-STG = ZERO
  11082. 056700         GO TO 415-EXIT.
  11083. 056800     COMPUTE PCT-HLD ROUNDED =  PCT-TOT-PHNO-STG /
  11084. 056900                                REC-CNT-PHNO-STG.
  11085. 057000     MOVE PCT-HLD TO ADW-PCT (PHNO-STG-HLD).
  11086. 057100     IF DISPLAY-SW = 2
  11087. 057200         MOVE PCT-HLD TO DDD
  11088. 057300         MOVE PCT-TOT-PHNO-STG TO EEE
  11089. 057400         MOVE REC-CNT-PHNO-STG TO FFF
  11090. 057500         DISPLAY "PH=" DDD " PT=" EEE " RC=" FFF.
  11091. 057600     MOVE ZERO TO PCT-TOT-PHNO-STG REC-CNT-PHNO-STG.
  11092. 057700 415-EXIT.
  11093. 057800     EXIT.
  11094. 057900 430-SUM.
  11095. 058000     PERFORM 415-CAL-ADW-PCT THRU 415-EXIT.
  11096. 058100     PERFORM 500-FINAL-CALCS.
  11097. 058200     PERFORM 700-BUILD-SPEC-REC.
  11098. 058300     PERFORM 750-INITIALIZE.
  11099. 058400     GO TO 400-PROCESS.
  11100. 058500     GO TO 400-PROCESS.
  11101. 058600 500-FINAL-CALCS.
  11102. 058700*    CALCULATE THE GRAMS PER SQ FT PER STAGE FOR PREVIOUSLY
  11103. 058800*        COLLECTED PLANT.  DETERMINE THE GRAMS PER SQ FT AT FULL
  11104. 058900*         PRODUCTION (MAX-GRAMS).
  11105. 059000     PERFORM 600-CALC-GRAMS VARYING I FROM 1 BY 1 UNTIL I > 8.
  11106. 059100*    CALCULATE THE PERCENT PER PHENOLOGY STAGE FOR PREVIOUSLY
  11107. 059200*         COLLECTED PLANT.
  11108. 059300     PERFORM 610-CALC-PERCENT-OF-MAX VARYING I FROM 1 BY 1
  11109. 059400         UNTIL I > 8.
  11110. 059500     IF DISPLAY-SW = 1 OR 2 OR 3
  11111. 059600     DISPLAY "PERCENTS OF MAX = " PERCENT-PER-STG.
  11112. 059700*    CALCULATE THE ADJUSTMENT FACTOR PER STAGE FOR PREVIOUSLY
  11113. 059800*         COLLECTED PLANT.
  11114. 059900     PERFORM 620-CALC-ADJ VARYING I FROM 1 BY 1 UNTIL I > 8.
  11115. 060000     IF DISPLAY-SW = 1 OR 2 OR 3
  11116. 060100     DISPLAY "ADJ FACTORS = " ADJ-FACTOR.
  11117. 060200 500-EXIT.
  11118. 060300     EXIT.
  11119. 060400 600-CALC-GRAMS.
  11120. 060500     MOVE ZERO TO GRAMS-FT (I).
  11121. 060600     IF RECNT (I) NOT = ZERO
  11122. 060700         COMPUTE GRAMS-FT (I) = GPF-TOT (I) / RECNT (I).
  11123. 060800     IF DISPLAY-SW = 1 OR 2 OR 3 AND (GRAMS-FT (I) > ZERO)
  11124. 060900         MOVE GRAMS-FT (I) TO DDD
  11125. 061000         MOVE GPF-TOT (I) TO EEE
  11126. 061100         MOVE RECNT (I) TO FFF
  11127. 061200         DISPLAY "GRAMS-FT (" I ")  = " DDD
  11128. 061300                 " GPF-TOT (" I ")  = " EEE
  11129. 061400                 " RECDS (" I ")  = " FFF.
  11130. 061500     IF RECNT (I) NOT = ZERO
  11131. 061600         IF GRAMS-FT (I) > MAX-GRAMS
  11132. 061700             MOVE GRAMS-FT (I) TO MAX-GRAMS.
  11133. 061800 610-CALC-PERCENT-OF-MAX.
  11134. 061900     MOVE ZERO TO PERSENT (I).
  11135. 062000     IF GRAMS-FT (I) NOT = ZERO
  11136. 062100         COMPUTE PERSENT (I) = GRAMS-FT (I) / MAX-GRAMS.
  11137. 062200     IF DISPLAY-SW = 1 OR 2 OR 3 AND (PERSENT (I) > ZERO)
  11138. 062300         MOVE PERSENT (I) TO DDD
  11139. 062400         MOVE GRAMS-FT (I) TO EEE
  11140. 062500         MOVE MAX-GRAMS TO FFF
  11141. 062600         DISPLAY "PERSENT (" I ")  = " DDD
  11142. 062700                 " GRAMS-FT (" I ")  = " EEE
  11143. 062800                " MAX-GRAMS = " FFF.
  11144. 062900 620-CALC-ADJ.
  11145. 063000     IF (PERSENT (I) NOT = ZERO)
  11146. 063100         AND (ADJ-FAC (I) = ZERO OR SPACE)
  11147. 063200         COMPUTE ADJ-FAC (I) ROUNDED = 1   / PERSENT (I).
  11148. 063300     IF DISPLAY-SW = 1 OR 2 OR 3 AND (ADJ-FAC (I) > ZERO)
  11149. 063400         MOVE PERSENT (I) TO DDD
  11150. 063500         MOVE ADJ-FAC (I) TO EEE
  11151. 063600         DISPLAY "PERSENT (" I ")  = " DDD
  11152. 063700                " ADJ-FAC (" I ")  = " EEE.
  11153. 063800 700-BUILD-SPEC-REC.
  11154. 063900     MOVE SPACE TO SPEC-AFR.
  11155. 064000     MOVE SDRP-HLD TO SDRP-AFR.
  11156. 064100     MOVE PLANT-CD-HLD TO PLANT-CD-AFR
  11157. 064200     IF PLANT-TYP-H = "G" MOVE "1" TO PLANT-TYP-AFR.
  11158. 064300     IF PLANT-TYP-H = "F" MOVE "2" TO PLANT-TYP-AFR.
  11159. 064400     IF PLANT-TYP-H = "S" OR "T" MOVE "3" TO PLANT-TYP-AFR.
  11160. 064500     MOVE ADJ-FAC (1) TO PAF-AFR (1).
  11161. 064600     MOVE ADJ-FAC (2) TO PAF-AFR (2).
  11162. 064700     MOVE ADJ-FAC (3) TO PAF-AFR (3).
  11163. 064800     MOVE ADJ-FAC (4) TO PAF-AFR (4).
  11164. 064900     MOVE ADJ-FAC (5) TO PAF-AFR (5).
  11165. 065000     MOVE ADJ-FAC (6) TO PAF-AFR (6).
  11166. 065100     MOVE ADJ-FAC (7) TO PAF-AFR (7).
  11167. 065200     MOVE ADJ-FAC (8) TO PAF-AFR (8).
  11168. 065300     MOVE ADW-PCT (1) TO ADW-PCT-AFR (1).
  11169. 065400     MOVE ADW-PCT (2) TO ADW-PCT-AFR (2).
  11170. 065500     MOVE ADW-PCT (3) TO ADW-PCT-AFR (3).
  11171. 065600     MOVE ADW-PCT (4) TO ADW-PCT-AFR (4).
  11172. 065700     MOVE ADW-PCT (5) TO ADW-PCT-AFR (5).
  11173. 065800     MOVE ADW-PCT (6) TO ADW-PCT-AFR (6).
  11174. 065900     MOVE ADW-PCT (7) TO ADW-PCT-AFR (7).
  11175. 066000     MOVE ADW-PCT (8) TO ADW-PCT-AFR (8).
  11176. 066100     IF (DISPLAY-SW = 1 OR 2 OR 3)
  11177. 066200      ADD 1 TO CNT-SUM
  11178. 066300         DISPLAY SPEC-AFR.
  11179. 066400*    DISPLAY SPEC-AFR.
  11180. 066500     ADD 1 TO CNT-2.
  11181. 066600     MOVE SPEC-AFR TO FDR-I1-I2
  11182. 066700     WRITE FDR-I1-I2 INVALID KEY
  11183. 066800         DISPLAY INDEX-KEY FILE-STATUS.
  11184. 066900     IF DISPLAY-SW = 1 OR 3 MOVE 0 TO DISPLAY-SW.
  11185. 067000 750-INITIALIZE.
  11186. 067100     MOVE CNTL-D1 TO CNTL-HLD.
  11187. 067200     MOVE PHENO-SR TO PHNO-STG-HLD.
  11188. 067300     INITIALIZE BASAL-CROWN-AREA-PER-STG
  11189. 067400         WGT-PER-STG
  11190. 067500          GRAMS-PER-SQ-FT
  11191. 067600          PERCENT-PER-STG
  11192. 067700          I
  11193. 067800          MAX-TEMP
  11194. 067900          MIN-TEMP
  11195. 068000          MAX-GRAMS
  11196. 068100         ADJ-FACTOR
  11197. 068200         ADW-PCT-TAB
  11198. 068300          SQ-FT-TEMP.
  11199. 068400 800-EXIT.
  11200. 068500     EXIT.
  11201. 068600 900-DUMMY SECTION.
  11202. 068700 999-END.
  11203. 068800     STOP RUN.
  11204. 068900*991.........2........3.........4.........5.........6.........7..
  11205. 000000*-----------------------------------------------------------------
  11206. 000100 IDENTIFICATION DIVISION.
  11207. 000200 PROGRAM-ID. ES208M.
  11208. 000300*        CONVERTS NEW FORMAT VA RECORDS TO OLD FORMAT (D) RECORDS
  11209. 000400*
  11210. 000500 AUTHOR. GEORGIA BOSSE.
  11211. 000600 INSTALLATION.         BLM.
  11212. 000700 DATE-WRITTEN.         DECEMBER 1982.
  11213. 000800*REMARKS.     VA CONVERSION-D
  11214. 000900*        THE INPUT FILES ARE THE KEY ENTERED VA AND VB RECORDS.
  11215. 001000*        VA = BLM FORM 4412-29 (APRIL 1982)
  11216. 001100*        VB = BLM FORM 4412-30 (APRIL 1982)
  11217. 001200*        THE OUTPUT IS FORMATTED LIKE THE KEY ENTERED VA1D RECORDS
  11218. 001300*        VA1D = BLM FORM 4412-29 (JUNE 79)
  11219. 001400*        THE PROGRAM SORTS THE VA FILE BY SWA INTO A TEMPORARY FIL
  11220. 001500*        AND THEN SORTS THE VB FILE BY SWA.  THE TWO FILES ARE MAT
  11221. 001600*        ON SWA# AND ALL VA RECORDS FOR WHICH THERE IS A MATCHING
  11222. 001700*        VB RECORD ARE REFORMATTED INTO THE VA1D FILE.  IF NO MATC
  11223. 001800*        VB RECORD IS FOUND AN ERROR MESSAGE IS PRINTED AND THE PR
  11224. 001900*        READS THE NEXT VA RECORD.  IF THE PROGRAM REACHES THE END
  11225. 002000*        OF THE VB FILE WITHOUT MATCHING THE VA SWA OR FINDING A H
  11226. 002100*        SWA THE PROGRAM PRINTS A MESSAGE AND TERMINATES.
  11227. 002200 ENVIRONMENT DIVISION.
  11228. 002300 CONFIGURATION SECTION.
  11229. 002400 SOURCE-COMPUTER.      LEVEL-66-ASCII.
  11230. 002500 OBJECT-COMPUTER.      LEVEL-66-ASCII SEQUENCE IS EBCDIC.
  11231. 002600 INPUT-OUTPUT SECTION.
  11232. 002700 FILE-CONTROL.
  11233. 002800     SELECT  VA1D-FILE  ASSIGN D1
  11234. 002900             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  11235. 003000     SELECT  VA-FILE ASSIGN I1
  11236. 003100             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  11237. 003200     SELECT  VB-FILE ASSIGN I2
  11238. 003300             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  11239. 003400     SELECT VA-SORT-OUT-FILE ASSIGN DZ.
  11240. 003500     SELECT VA-SORT-FILE ASSIGN ASORT.
  11241. 003600     SELECT VB-SORT-FILE ASSIGN BSORT.
  11242. 003700 DATA DIVISION.
  11243. 003800 FILE SECTION.
  11244. 003900 FD  VA-FILE
  11245. 004000     CODE-SET IS GBCD
  11246. 004100     LABEL RECORDS ARE STANDARD
  11247. 004200     DATA RECORD IS VA-REC.
  11248. 004300 01  VA-REC.
  11249. 004400     03  PG-NUM-I1               PIC 9999.
  11250. 004500     03  INV-CD-I1               PIC XXXX.
  11251. 004600     03  REC-TYP-I1              PIC XXX.
  11252. 004700     03  MAP-TYP-I1              PIC XXX.
  11253. 004800     03  GEO-ST-I1               PIC XX.
  11254. 004900     03  MER-I1                  PIC XX.
  11255. 005000     03  MAP-QUAD-I1             PIC 9(8).
  11256. 005100     03  LIN-NUM-I1              PIC 99.
  11257. 005200     03  ACT-I1                  PIC X.
  11258. 005300     03  SWA-I1                  PIC XXXX.
  11259. 005400     03  ACRES-I1                PIC 9(5).
  11260. 005500     03  TR-ID-I1                PIC X.
  11261. 005600     03  SECT-I1                 PIC 999.
  11262. 005700     03  TWP-I1                  PIC X(5).
  11263. 005800     03  RNG-I1                  PIC X(5).
  11264. 005900     03  SURF-OWN-I1             PIC XXXX.
  11265. 006000     03  ADM-I1                  PIC X(4).
  11266. 006100     03  JURIS-I1                PIC X(4).
  11267. 006200     03  TYP-I1                  PIC X(4).
  11268. 006300     03  FILLER                  PIC X(16).
  11269. 006400 FD  VB-FILE
  11270. 006500     CODE-SET IS GBCD
  11271. 006600     LABEL RECORDS ARE STANDARD
  11272. 006700     DATA RECORD IS VB-REC.
  11273. 006800 01  VB-REC.
  11274. 006900     03  PG-I2                   PIC X(4).
  11275. 007000     03  INV-CD-I2               PIC X(4).
  11276. 007100     03  REC-TYP-I2              PIC XXX.
  11277. 007200     03  RA-I2                   PIC XX.
  11278. 007300     03  PU-I2                   PIC XX.
  11279. 007400     03  ALLOT-I2                PIC X(4).
  11280. 007500     03  PASTR-I2                PIC XX.
  11281. 007600     03  LINE-NUM-I2             PIC XX.
  11282. 007700     03  ACT-I2                  PIC X.
  11283. 007800     03  SWA-I2                  PIC X(4).
  11284. 007900     03  TRN-I2                  PIC XX.
  11285. 008000     03  PCT-SWA-I2              PIC XXX.
  11286. 008100     03  STRAT-I2                PIC X(4).
  11287. 008200     03  CLMTC-ADJ-FCTR-I2       PIC 99V999.
  11288. 008300     03  ELEV-I2                 PIC X(5).
  11289. 008400     03  PCT-SLP-I2              PIC XXX.
  11290. 008500     03  SLP-ASPT-I2             PIC XX.
  11291. 008600     03  LND-FRM-I2              PIC XXX.
  11292. 008700     03  SOIL-PHS-I2             PIC X(6).
  11293. 008800     03  FILLER                  PIC X(23).
  11294. 008900 FD  VA1D-FILE
  11295. 009000     CODE-SET IS GBCD
  11296. 009100     LABEL RECORDS ARE STANDARD
  11297. 009200     DATA RECORD IS VA1D-REC.
  11298. 009300 01  VA1D-REC.
  11299. 009400     03  REC-TYPE-D1             PIC X(4).
  11300. 009500     03  STATE-DIST-D1           PIC X(4).
  11301. 009600     03  RA-D1                   PIC XX.
  11302. 009700     03  PU-D1                   PIC XX.
  11303. 009800     03  ALLOT-D1                PIC X(4).
  11304. 009900     03  PASTR-D1                PIC XX.
  11305. 010000     03  DATE-D1                 PIC X(6).
  11306. 010100     03  ACT-D1                  PIC X.
  11307. 010200     03  MAP-SRC-D1              PIC X(4).
  11308. 010300     03  MER-D1                  PIC XX.
  11309. 010400     03  LINE-NUM-D1             PIC X(4).
  11310. 010500     03  TWP-D1                  PIC X(5).
  11311. 010600     03  RNG-D1                  PIC X(5).
  11312. 010700     03  SECT-D1                 PIC XXX.
  11313. 010800     03  SWA-D1                  PIC X(4).
  11314. 010900     03  QUARTERS-D1             PIC X(16).
  11315. 011000     03  ACRES-D1                PIC X(5).
  11316. 011100     03  SURF-OWN-D1             PIC X(4).
  11317. 011200     03  JURIS-D1                PIC X(4).
  11318. 011300     03  ADM-D1                  PIC X(4).
  11319. 011400     03  TYP-D1                  PIC X(4).
  11320. 011500     03  FIL                     PIC X.
  11321. 011600 FD  VA-SORT-OUT-FILE
  11322. 011700     LABEL RECORDS ARE STANDARD
  11323. 011800     DATA RECORD IS VA-SORT-OUT.
  11324. 011900 01  VA-SORT-OUT.
  11325. 012000     03  PG-NUM-SVA              PIC 9999.
  11326. 012100     03  INV-CD-SVA              PIC XXXX.
  11327. 012200     03  REC-TYP-SVA             PIC XXX.
  11328. 012300     03  MAP-TYP-SVA             PIC XXX.
  11329. 012400     03  GEO-ST-SVA              PIC XX.
  11330. 012500     03  MER-SVA                 PIC XX.
  11331. 012600     03  MAP-QUAD-SVA            PIC 9(8).
  11332. 012700     03  LIN-NUM-SVA             PIC 99.
  11333. 012800     03  ACT-SVA                 PIC X.
  11334. 012900     03  SWA-SVA                 PIC XXXX.
  11335. 013000     03  ACRES-SVA               PIC 9(5).
  11336. 013100     03  TR-ID-SVA               PIC X.
  11337. 013200     03  SECT-SVA                PIC 999.
  11338. 013300     03  TWP-SVA                 PIC X(5).
  11339. 013400     03  RNG-SVA                 PIC X(5).
  11340. 013500     03  SURF-OWN-SVA            PIC XXXX.
  11341. 013600     03  ADM-SVA                 PIC X(4).
  11342. 013700     03  JURIS-SVA               PIC X(4).
  11343. 013800     03  TYP-SVA                 PIC X(4).
  11344. 013900     03  FILLER                  PIC X(16).
  11345. 014000 SD  VA-SORT-FILE
  11346. 014100     DATA RECORD IS VA-SORT-REC.
  11347. 014200 01  VA-SORT-REC.
  11348. 014300     03  FILLER              PIC X(29).
  11349. 014400     03  SWA-IS-KEY          PIC XXXX.
  11350. 014500     03  FILLER              PIC X(51).
  11351. 014600 SD  VB-SORT-FILE
  11352. 014700     DATA RECORD IS VB-SORT-REC.
  11353. 014800 01  VB-SORT-REC.
  11354. 014900     03  PG-SVB                  PIC X(4).
  11355. 015000     03  INV-SVB                 PIC X(4).
  11356. 015100     03  REC-TYP-SVB             PIC XXX.
  11357. 015200     03  RA-SVB                  PIC XX.
  11358. 015300     03  PU-SVB                  PIC XX.
  11359. 015400     03  ALLOT-SVB               PIC X(4).
  11360. 015500     03  PASTR-SVB               PIC XX.
  11361. 015600     03  LINE-NUM-SVB            PIC XX.
  11362. 015700     03  ACT-SVB                 PIC X.
  11363. 015800     03  SWA-SVB                 PIC X(4).
  11364. 015900     03  TRN-SVB                 PIC XX.
  11365. 016000     03  PCT-SWA-SVB             PIC XXX.
  11366. 016100     03  STRAT-SVB               PIC X(4).
  11367. 016200     03  CLMTC-ADJ-FCTR-SVB      PIC 99V999.
  11368. 016300     03  ELEV-SVB                PIC X(5).
  11369. 016400     03  PCT-SLP-SVB             PIC XXX.
  11370. 016500     03  SLP-ASPT-SVB            PIC XX.
  11371. 016600     03  LND-FRM-SVB             PIC XXX.
  11372. 016700     03  SOIL-PHS-SVB            PIC X(6).
  11373. 016800     03  FILLER                  PIC X(23).
  11374. 016900 WORKING-STORAGE SECTION.
  11375. 017000 77  ERR-CNT                     PIC 9  VALUE ZERO.
  11376. 017100 77  VA1D-CNT                    PIC 99999  VALUE ZERO.
  11377. 017200 77  TODAYS-DATE                 PIC X(06).
  11378. 017300 01  INV-ST-DIST.
  11379. 017400     03  INVENTORY               PIC XXXX.
  11380. 017500     03  STATE-DIST              PIC X(4).
  11381. 017600 PROCEDURE DIVISION.
  11382. 017700 A100-HOUSE SECTION.
  11383. 017800 A100-HOUSEKEEPING.
  11384. 017900     ACCEPT TODAYS-DATE FROM DATE.
  11385. 018000     ACCEPT INV-ST-DIST.
  11386. 018100 B200-SORT-VA SECTION.
  11387. 018200 B210-SORT-VA.
  11388. 018300     SORT VA-SORT-FILE ON ASCENDING KEY
  11389. 018400         SWA-IS-KEY
  11390. 018500         INPUT PROCEDURE IS C300-INPUT-VA
  11391. 018600            GIVING VA-SORT-OUT-FILE.
  11392. 018700 B250-SORT-VB SECTION.
  11393. 018800 B260-SORT-VB.
  11394. 018900     CLOSE VA-FILE.
  11395. 019000     SORT VB-SORT-FILE ON ASCENDING KEY
  11396. 019100         SWA-SVB
  11397. 019200         INPUT PROCEDURE IS D400-INPUT-VB
  11398. 019300             OUTPUT PROCEDURE IS E600-OUTPUT.
  11399. 019400 B290-STOP.
  11400. 019500     CLOSE VA1D-FILE VA-SORT-OUT-FILE.
  11401. 019600     DISPLAY " OUTPUT RECORDS=" VA1D-CNT
  11402. 019700     STOP RUN.
  11403. 019800 C300-INPUT-VA SECTION.
  11404. 019900 C310-OPEN.
  11405. 020000     MOVE ZERO TO ERR-CNT.
  11406. 020100     OPEN INPUT VA-FILE.
  11407. 020200 C320-READ-VA-FILE.
  11408. 020300     READ VA-FILE AT END
  11409. 020400         GO TO C300-EXIT.
  11410. 020500     IF REC-TYP-I1 NOT = "VA "
  11411. 020600         ADD 1 TO ERR-CNT
  11412. 020700         DISPLAY " INVALID REC-TYP-I1 "  VA-REC
  11413. 020800         IF ERR-CNT = 5
  11414. 020900             DISPLAY " CHECK COMPLETE FILE - ABORT - "
  11415. 021000             STOP RUN
  11416. 021100             ELSE
  11417. 021200             GO TO C320-READ-VA-FILE.
  11418. 021300     IF INVENTORY NOT = INV-CD-I1
  11419. 021400         DISPLAY " INVENTORY UNMATCHED WITH VA-REC"
  11420. 021500         DISPLAY " INVENTORY REQUESTED= " INVENTORY
  11421. 021600         DISPLAY "THIS FILE IS   " INV-CD-I1
  11422. 021700         STOP RUN.
  11423. 021800     MOVE VA-REC TO VA-SORT-REC.
  11424. 021900     RELEASE VA-SORT-REC.
  11425. 022000     GO TO C320-READ-VA-FILE.
  11426. 022100 C300-EXIT.
  11427. 022200     EXIT.
  11428. 022300 D400-INPUT-VB SECTION.
  11429. 022400 D410-OPEN.
  11430. 022500     MOVE ZERO TO ERR-CNT.
  11431. 022600     OPEN INPUT VB-FILE.
  11432. 022700 D420-READ-VB-FILE.
  11433. 022800     READ VB-FILE AT END
  11434. 022900         GO TO D400-EXIT.
  11435. 023000     IF REC-TYP-I2 NOT = "VB "
  11436. 023100         ADD 1 TO ERR-CNT
  11437. 023200         DISPLAY " INVALID REC-TYP-I2 "  VB-REC
  11438. 023300         IF ERR-CNT = 5
  11439. 023400             DISPLAY " CHECK COMPLETE FILE - ABORT - "
  11440. 023500             STOP RUN
  11441. 023600             ELSE
  11442. 023700             GO TO D420-READ-VB-FILE.
  11443. 023800     IF INVENTORY NOT = INV-CD-I2
  11444. 023900         DISPLAY " INVENTORY UNMATCHED WITH VB-REC"
  11445. 024000         DISPLAY " INVENTORY REQUESTED= " INVENTORY
  11446. 024100         DISPLAY "THIS FILE IS   " INV-CD-I2
  11447. 024200         STOP RUN.
  11448. 024300     MOVE VB-REC TO VB-SORT-REC.
  11449. 024400     RELEASE VB-SORT-REC.
  11450. 024500     GO TO D420-READ-VB-FILE.
  11451. 024600 D400-EXIT.
  11452. 024700     EXIT.
  11453. 024800 E600-OUTPUT SECTION.
  11454. 024900 E610-OPEN.
  11455. 025000     OPEN INPUT VA-SORT-OUT-FILE.
  11456. 025100     OPEN OUTPUT VA1D-FILE.
  11457. 025200     CLOSE VB-FILE.
  11458. 025300     RETURN VB-SORT-FILE AT END
  11459. 025400         DISPLAY "VB SORT FILE ERROR"
  11460. 025500         STOP RUN.
  11461. 025600 E620-RETURN.
  11462. 025700     READ VA-SORT-OUT-FILE AT END
  11463. 025800         GO TO E600-EXIT.
  11464. 025900     IF SWA-SVA > SWA-SVB
  11465. 026000         PERFORM E680-FIND-MATCH.
  11466. 026100     IF SWA-SVA < SWA-SVB
  11467. 026200          DISPLAY "SWA #" SWA-SVA
  11468. 026300      " ON THE VA FILE HAS NO MATCHING SWA ON THE VB FILE"
  11469. 026400         GO TO E620-RETURN.
  11470. 026500* MOVE STANDARD FILE DATA
  11471. 026600     MOVE STATE-DIST TO STATE-DIST-D1.
  11472. 026700     MOVE "A" TO ACT-D1.
  11473. 026800     MOVE TODAYS-DATE TO DATE-D1.
  11474. 026900     MOVE "VA1D" TO REC-TYPE-D1.
  11475. 027000     MOVE SPACES TO QUARTERS-D1.
  11476. 027100     MOVE ZEROES TO LINE-NUM-D1.
  11477. 027200* MOVE DATA FROM VB-RECORD
  11478. 027300     MOVE SWA-SVB TO SWA-D1.
  11479. 027400     MOVE RA-SVB TO RA-D1.
  11480. 027500     MOVE PU-SVB TO PU-D1.
  11481. 027600     MOVE ALLOT-SVB TO ALLOT-D1.
  11482. 027700     MOVE PASTR-SVB TO PASTR-D1.
  11483. 027800* MOVE DATA FROM VA-RECORD
  11484. 027900     IF MAP-TYP-SVA = "    "
  11485. 028000         MOVE "MISC" TO MAP-SRC-D1.
  11486. 028100     IF MAP-TYP-SVA = "TF  "
  11487. 028200         MOVE "GS  " TO MAP-SRC-D1.
  11488. 028300     IF MAP-TYP-SVA = "OQ  "
  11489. 028400         MOVE "OR  " TO MAP-SRC-D1.
  11490. 028500     IF MAP-TYP-SVA = "PL  "
  11491. 028600         MOVE "PM  " TO MAP-SRC-D1.
  11492. 028700     IF MAP-TYP-SVA = "BSP "
  11493. 028800         MOVE "SP  " TO MAP-SRC-D1.
  11494. 028900     MOVE MER-SVA TO MER-D1.
  11495. 029000     MOVE TWP-SVA TO TWP-D1.
  11496. 029100     MOVE RNG-SVA TO RNG-D1.
  11497. 029200     MOVE SECT-SVA TO SECT-D1.
  11498. 029300     MOVE ACRES-SVA TO ACRES-D1.
  11499. 029400     MOVE SURF-OWN-SVA TO SURF-OWN-D1.
  11500. 029500     MOVE JURIS-SVA TO JURIS-D1.
  11501. 029600     MOVE ADM-SVA TO ADM-D1.
  11502. 029700     MOVE TYP-SVA TO TYP-D1.
  11503. 029800     WRITE VA1D-REC.
  11504. 029900     ADD 1 TO VA1D-CNT.
  11505. 030000     GO TO E620-RETURN.
  11506. 030100 E680-FIND-MATCH.
  11507. 030200     RETURN VB-SORT-FILE AT END
  11508. 030300          DISPLAY "CURRENT VA FILE IS AT SWA #" SWA-SVA
  11509. 030400          DISPLAY "THERE ARE NO MORE SWAS ON THE VB FILE"
  11510. 030500          GO TO E600-EXIT.
  11511. 030600     IF SWA-SVA > SWA-SVB
  11512. 030700          GO TO E680-FIND-MATCH.
  11513. 030800 E600-EXIT.
  11514. 030900     EXIT.
  11515. 031000 DUMMY SECTION.
  11516. 031100 D900-END.
  11517. 000000*-----------------------------------------------------------------
  11518. 000100 IDENTIFICATION DIVISION.
  11519. 000200 PROGRAM-ID. ES210U.
  11520. 000300*        INITIAL VA EDIT/UPDATE
  11521. 000400*
  11522. 000500 AUTHOR. CARLANDER.
  11523. 000600 INSTALLATION.         BLM.
  11524. 000700 DATE-WRITTEN.         SEPTEMBER, 1979.
  11525. 000800 ENVIRONMENT DIVISION.
  11526. 000900 CONFIGURATION SECTION.
  11527. 001000 SOURCE-COMPUTER.      LEVEL-66-ASCII.
  11528. 001100 OBJECT-COMPUTER.      LEVEL-66-ASCII SEQUENCE IS EBCDIC.
  11529. 001200 INPUT-OUTPUT SECTION.
  11530. 001300 FILE-CONTROL.
  11531. 001400     SELECT  NEW-FILE  ASSIGN D1
  11532. 001500             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  11533. 001600     SELECT  TRAN-FILE  ASSIGN I1
  11534. 001700             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  11535. 001800     SELECT  OPTIONAL PREV-FILE ASSIGN I2
  11536. 001900             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  11537. 002000     SELECT  SORT-WORK ASSIGN I1 I2 I3.
  11538. 002100*
  11539. 002200 DATA DIVISION.
  11540. 002300 FILE SECTION.
  11541. 002400 FD  PREV-FILE
  11542. 002500     CODE-SET IS GBCD
  11543. 002600     LABEL RECORDS ARE STANDARD
  11544. 002700     DATA RECORD IS VA1X-RCD.
  11545. 002800 01  VA1X-RCD.
  11546. 002900     02  KEY-VA1X.
  11547. 003000         03  DIC-VA1X.
  11548. 003100             04  REC-TYP-3529-VA1X   PIC X(02).
  11549. 003200             04  FMT-NUM-3576-VA1X   PIC X(01).
  11550. 003300             04  FMT-CD-3579-VA1X    PIC X(01).
  11551. 003400         03  BLM-ADM-U-0003-VA1X.
  11552. 003500             04  BLM-ADM-U-0003-ST-VA1X    PIC X(02).
  11553. 003600             04  BLM-ADM-U-0003-DIST-VA1X  PIC X(02).
  11554. 003700             04  BLM-ADM-U-0003-RA-VA1X    PIC X(02).
  11555. 003800             04  BLM-ADM-U-0003-PLU-VA1X   PIC X(02).
  11556. 003900         03  ALLOT-PAST-VA1X.
  11557. 004000             05  ALLOT-NUM-0968-VA1X           PIC X(04).
  11558. 004100             05  PASTURE-NUM-3905-VA1X         PIC X(02).
  11559. 004200         03  DATA-DATE-6618-VA1X.
  11560. 004300             04  DATA-DATE-6618-XY-VA1X    PIC X(02).
  11561. 004400             04  DATA-DATE-6618-MM-VA1X    PIC X(02).
  11562. 004500             04  DATA-DATE-6618-DD-VA1X    PIC X(02).
  11563. 004600         03  ACTN-CD-7350-VA1X             PIC X(01).
  11564. 004700         03  MAP-SRC-3540-VA1X             PIC X(04).
  11565. 004800         03  MTR-MER-CD-1703-VA1X          PIC X(02).
  11566. 004900         03  LIN-NUM-3578-VA1X             PIC X(04).
  11567. 005000     02  MTR-TWNSHP-1695-VA1X              PIC X(05).
  11568. 005100     02  MTR-RNG-1699-VA1X                 PIC X(05).
  11569. 005200     02  SEC-SECT-2506-VA1X                PIC X(03).
  11570. 005300     02  SWA-3507-VA1X                     PIC X(04).
  11571. 005400     02  ALIQ-PART-2904-VA1X               PIC X(04) OCCURS 4.
  11572. 005500     02  ACR-DU-6520-OWNR-VA1X             PIC X(05).
  11573. 005600     02  OWN-TYP-2531-VA1X                 PIC X(04).
  11574. 005700     02  JURIS-2572-VA1X                   PIC X(04).
  11575. 005800     02  MGT-ADM-2570-VA1X                 PIC X(04).
  11576. 005900     02  LAND-TYP-3801-VA1X                PIC X(04).
  11577. 006000     02  OPEN-VA1X                         PIC X(01).
  11578. 006100 SD  SORT-WORK
  11579. 006200     DATA RECORD IS SORT-RCD.
  11580. 006300 01  SORT-RCD.
  11581. 006400     03  CNTL-1-SR.
  11582. 006500         05  REC-TYP-SR    PIC XXXX.
  11583. 006600         05  SDRP-SR       PIC X(8).
  11584. 006700         05  ALLOT-PAST-SR PIC X(6).
  11585. 006800     03  FILLER        PIC X(7).
  11586. 006900     03  DATA-1-SR.
  11587. 007000         05  MAP-SRC-SR    PIC XXXX.
  11588. 007100         05  MTR-MER-CD-SR PIC XX.
  11589. 007200     03  LINE-SR       PIC XXXX.
  11590. 007300     03  DATA-2-SR.
  11591. 007400         05  MTR-TWNSHP-SR PIC X(5).
  11592. 007500         05  MTR-RNG-SR    PIC X(5).
  11593. 007600         05  SEC-SECT-SR   PIC XXX.
  11594. 007700         05  SWA-SR        PIC XXXX.
  11595. 007800         05  FILLER        PIC X(37).
  11596. 007900     03  FILLER        PIC X.
  11597. 008000 FD  TRAN-FILE
  11598. 008100     CODE-SET IS GBCD
  11599. 008200     LABEL RECORDS ARE STANDARD
  11600. 008300     DATA RECORD IS VA1K-RCD.
  11601. 008400 01 VA1K-RCD.
  11602. 008500     02  KEY-VA1K.
  11603. 008600         03  DIC-VA1K.
  11604. 008700             04  REC-TYP-3529-VA1K   PIC X(02).
  11605. 008800             04  FMT-NUM-3576-VA1K   PIC X(01).
  11606. 008900             04  FMT-CD-3579-VA1K    PIC X(01).
  11607. 009000         03  BLM-ADM-U-0003-VA1K.
  11608. 009100             04  BLM-ADM-U-0003-ST-VA1K    PIC X(02).
  11609. 009200             04  BLM-ADM-U-0003-DIST-VA1K  PIC X(02).
  11610. 009300             04  BLM-ADM-U-0003-RA-VA1K    PIC X(02).
  11611. 009400             04  BLM-ADM-U-0003-PLU-VA1K   PIC X(02).
  11612. 009500         03  ALLOT-NUM-0968-VA1K           PIC X(04).
  11613. 009600         03  PASTURE-NUM-3905-VA1K         PIC X(02).
  11614. 009700         03  DATA-DATE-6618-VA1K.
  11615. 009800             04  DATA-DATE-6618-XY-VA1K    PIC X(02).
  11616. 009900             04  DATA-DATE-6618-MM-VA1K    PIC X(02).
  11617. 010000             04  DATA-DATE-6618-DD-VA1K    PIC X(02).
  11618. 010100         03  ACTN-CD-7350-VA1K             PIC X(01).
  11619. 010200         03  MAP-SRC-3540-VA1K             PIC X(04).
  11620. 010300         03  MTR-MER-CD-1703-VA1K          PIC X(02).
  11621. 010400         03  LIN-NUM-3578-VA1K             PIC X(04).
  11622. 010500     02  MTR-TWNSHP-1695-VA1K              PIC X(05).
  11623. 010600     02  MTR-RNG-1699-VA1K                 PIC X(05).
  11624. 010700     02  SEC-SECT-2506-VA1K                PIC X(03).
  11625. 010800     02  SWA-3507-VA1K                     PIC X(04).
  11626. 010900     02  ALIQ-PART-2904-VA1K               PIC X(04) OCCURS 4.
  11627. 011000     02  ACR-DU-6520-OWNR-VA1K             PIC X(05).
  11628. 011100     02  OWN-TYP-2531-VA1K                 PIC X(04).
  11629. 011200     02  JURIS-2572-VA1K                   PIC X(04).
  11630. 011300     02  MGT-ADM-2570-VA1K                 PIC X(04).
  11631. 011400     02  LAND-TYP-3801-VA1K                PIC X(04).
  11632. 011500     02  OPEN-VA1K                         PIC X(01).
  11633. 011600 FD  NEW-FILE
  11634. 011700     CODE-SET IS GBCD
  11635. 011800     LABEL RECORDS ARE STANDARD
  11636. 011900     DATA RECORD IS VA1Z-RCD.
  11637. 012000 01 VA1Z-RCD.
  11638. 012100     02  KEY-VA1Z.
  11639. 012200         03  DIC-VA1Z.
  11640. 012300             04  REC-TYP-3529-VA1Z   PIC X(02).
  11641. 012400             04  FMT-NUM-3576-VA1Z   PIC X(01).
  11642. 012500             04  FMT-CD-3579-VA1Z    PIC X(01).
  11643. 012600         03  BLM-ADM-U-0003-VA1Z.
  11644. 012700             04  BLM-ADM-U-0003-ST-VA1Z    PIC X(02).
  11645. 012800             04  BLM-ADM-U-0003-DIST-VA1Z  PIC X(02).
  11646. 012900             04  BLM-ADM-U-0003-RA-VA1Z    PIC X(02).
  11647. 013000             04  BLM-ADM-U-0003-PLU-VA1Z   PIC X(02).
  11648. 013100         03  ALLOT-PAST-VA1Z.
  11649. 013200             05  ALLOT-NUM-0968-VA1Z           PIC X(04).
  11650. 013300             05  PASTURE-NUM-3905-VA1Z         PIC X(02).
  11651. 013400         03  DATA-DATE-6618-VA1Z.
  11652. 013500             04  DATA-DATE-6618-XY-VA1Z    PIC X(02).
  11653. 013600             04  DATA-DATE-6618-MM-VA1Z    PIC X(02).
  11654. 013700             04  DATA-DATE-6618-DD-VA1Z    PIC X(02).
  11655. 013800         03  ACTN-CD-7350-VA1Z             PIC X(01).
  11656. 013900         03  MAP-SRC-3540-VA1Z             PIC X(04).
  11657. 014000         03  MTR-MER-CD-1703-VA1Z          PIC X(02).
  11658. 014100         03  LIN-NUM-3578-VA1Z             PIC X(04).
  11659. 014200     02  MTR-TWNSHP-1695-VA1Z              PIC X(05).
  11660. 014300     02  MTR-RNG-1699-VA1Z                 PIC X(05).
  11661. 014400     02  SEC-SECT-2506-VA1Z                PIC X(03).
  11662. 014500     02  SWA-3507-VA1Z                     PIC X(04).
  11663. 014600     02  ALIQ-PART-2904-VA1Z               PIC X(04) OCCURS 4.
  11664. 014700     02  ACR-DU-6520-OWNR-VA1Z             PIC X(05).
  11665. 014800     02  OWN-TYP-2531-VA1Z                 PIC X(04).
  11666. 014900     02  JURIS-2572-VA1Z                   PIC X(04).
  11667. 015000     02  MGT-ADM-2570-VA1Z                 PIC X(04).
  11668. 015100     02  LAND-TYP-3801-VA1Z                PIC X(04).
  11669. 015200     02  OPEN-VA1Z                         PIC X(01).
  11670. 015300 WORKING-STORAGE SECTION.
  11671. 015400 77  END-OF-TRAN                 PIC X(01) VALUE SPACE.
  11672. 015500 77  END-OF-PREV                 PIC X(01) VALUE SPACE.
  11673. 015600 77  DATE-SW                     PIC X(01).
  11674. 015700 77  DATE-MV-SW                  PIC X(01).
  11675. 015800 77  LAST-LIN-NUM                PIC 9(04) VALUE ZERO.
  11676. 015900 77  TODAYS-DATE                 PIC X(06).
  11677. 016000 77  VA-CTR                      PIC 9(5)  VALUE ZERO.
  11678. 016100*
  11679. 016200 01  PARAMETER.
  11680. 016300     03  RELINE-CHK    PIC XXX.
  11681. 016400     03  FILLER        PIC X(77).
  11682. 016500 01  DATE-WORK.
  11683. 016600     02  DW-YY                   PIC X(02).
  11684. 016700     02  DW-MM                   PIC X(02).
  11685. 016800     02  DW-DD                   PIC X(02).
  11686. 016900 01  MOVED-DATE.
  11687. 017000     02  MD-DD                   PIC X(02).
  11688. 017100     02  MD-YY                   PIC X(02).
  11689. 017200     02  MD-MM                   PIC X(02).
  11690. 017300 01  TRAN-CTL.
  11691. 017400     03  REC-TYP-TC    PIC XXXX.
  11692. 017500     03  SDRP-TC       PIC X(8).
  11693. 017600     03  ALLOT-PAST-TC PIC X(6).
  11694. 017700     03  LINE-TC       PIC XXXX.
  11695. 017800 01  PREV-CTL.
  11696. 017900     03  REC-TYP-PC    PIC XXXX.
  11697. 018000     03  SDRP-PC       PIC X(8).
  11698. 018100     03  ALLOT-PAST-PC PIC X(6).
  11699. 018200     03  LINE-PC       PIC XXXX.
  11700. 018300 01  CTL.
  11701. 018400     03  REC-TYP-C     PIC XXXX.
  11702. 018500     03  SDRP-C        PIC X(8).
  11703. 018600     03  ALLOT-PAST-C  PIC X(6).
  11704. 018700 01  CTL-SAVE.
  11705. 018800     03  REC-TYP-CS    PIC XXXX.
  11706. 018900     03  SDRP-CS       PIC X(8).
  11707. 019000     03  ALLOT-PAST-CS PIC X(6).
  11708. 019100*
  11709. 019200 PROCEDURE DIVISION.
  11710. 019300 000-DRIVER SECTION.
  11711. 019400 010-MAINLINE.
  11712. 019500     PERFORM 100-INITIALIZE.
  11713. 019600     PERFORM 200-SORT.
  11714. 019700     PERFORM 990-TERMINATE.
  11715. 019800     STOP RUN.
  11716. 019900*
  11717. 020000 100-INITIALIZE SECTION.
  11718. 020100 110-OPENS.
  11719. 020200     OPEN INPUT PREV-FILE TRAN-FILE
  11720. 020300         OUTPUT NEW-FILE.
  11721. 020400     MOVE ALL "9" TO PREV-CTL.
  11722. 020500     ACCEPT PARAMETER.
  11723. 020600     ACCEPT TODAYS-DATE FROM DATE.
  11724. 020700*
  11725. 020800 200-SORT SECTION.
  11726. 020900 210-SORT-VERB.
  11727. 021000     SORT SORT-WORK ASCENDING KEY
  11728. 021100         REC-TYP-SR SDRP-SR ALLOT-PAST-SR
  11729. 021200             LINE-SR SWA-SR MTR-MER-CD-SR MTR-RNG-SR
  11730. 021300                 MTR-TWNSHP-SR SEC-SECT-SR
  11731. 021400                    INPUT PROCEDURE 300-READ-RELEASE
  11732. 021500                    OUTPUT PROCEDURE 400-MATCH-UPDATE.
  11733. 021600*
  11734. 021700 300-READ-RELEASE SECTION.
  11735. 021800 300-READ-TRAN.
  11736. 021900     READ TRAN-FILE AT END GO TO 300-EXIT.
  11737. 022000     IF ACTN-CD-7350-VA1K = SPACE
  11738. 022100         MOVE "A" TO ACTN-CD-7350-VA1K.
  11739. 022200     IF (LIN-NUM-3578-VA1K NOT NUMERIC) OR
  11740. 022300        (LIN-NUM-3578-VA1K = "0000")
  11741. 022400         OR (RELINE-CHK = "YES")
  11742. 022500         MOVE "9999" TO LIN-NUM-3578-VA1K.
  11743. 022600     MOVE VA1K-RCD TO SORT-RCD.
  11744. 022700     RELEASE SORT-RCD.
  11745. 022800     GO TO 300-READ-TRAN.
  11746. 022900 300-EXIT.
  11747. 023000     EXIT.
  11748. 023100 400-MATCH-UPDATE SECTION.
  11749. 023200 410-GET-FIRST-RCDS.
  11750. 023300     PERFORM 430-RETURN-SORT.
  11751. 023400     PERFORM 440-READ-PREV.
  11752. 023500 420-COMPARE.
  11753. 023600     IF TRAN-CTL = ALL "9" AND
  11754. 023700        PREV-CTL = ALL "9"
  11755. 023800             GO TO 400-EXIT.
  11756. 023900     IF TRAN-CTL IS GREATER THAN PREV-CTL
  11757. 024000             PERFORM 500-NO-TRAN
  11758. 024100             GO TO 420-COMPARE.
  11759. 024200     IF PREV-CTL IS GREATER THAN TRAN-CTL
  11760. 024300             PERFORM 600-NO-PREV
  11761. 024400             GO TO 420-COMPARE.
  11762. 024500     IF TRAN-CTL IS EQUAL TO PREV-CTL
  11763. 024600             PERFORM 700-MATCH
  11764. 024700             GO TO 420-COMPARE.
  11765. 024800 430-RETURN-SORT.
  11766. 024900     RETURN SORT-WORK AT END
  11767. 025000             MOVE "X" TO END-OF-TRAN.
  11768. 025100     MOVE REC-TYP-SR TO REC-TYP-TC.
  11769. 025200     MOVE SDRP-SR TO SDRP-TC.
  11770. 025300     MOVE ALLOT-PAST-SR TO ALLOT-PAST-TC
  11771. 025400     MOVE LINE-SR TO LINE-TC.
  11772. 025500     IF END-OF-TRAN = "X"
  11773. 025600             MOVE ALL "9" TO TRAN-CTL.
  11774. 025700 440-READ-PREV.
  11775. 025800     READ PREV-FILE  AT END
  11776. 025900             MOVE "X" TO END-OF-PREV.
  11777. 026000     MOVE DIC-VA1X TO REC-TYP-PC.
  11778. 026100     MOVE BLM-ADM-U-0003-VA1X TO SDRP-PC.
  11779. 026200     MOVE ALLOT-PAST-VA1X TO ALLOT-PAST-PC.
  11780. 026300     MOVE LIN-NUM-3578-VA1X TO LINE-PC.
  11781. 026400     IF END-OF-PREV = "X"
  11782. 026500             MOVE ALL "9" TO PREV-CTL.
  11783. 026600 500-NO-TRAN.
  11784. 026700     MOVE VA1X-RCD TO VA1Z-RCD.
  11785. 026800     ADD 1 TO VA-CTR.
  11786. 026900     PERFORM 920-WRITE-Z.
  11787. 027000     PERFORM 440-READ-PREV.
  11788. 027100 600-NO-PREV.
  11789. 027200     MOVE SORT-RCD TO VA1Z-RCD.
  11790. 027300     ADD 1 TO VA-CTR.
  11791. 027400     PERFORM 810-BUILD-LIN.
  11792. 027500     PERFORM 820-CHECK-LIN THRU 820-OUT.
  11793. 027600     PERFORM 890-EDIT-DATE.
  11794. 027700     PERFORM 920-WRITE-Z.
  11795. 027800     PERFORM 430-RETURN-SORT.
  11796. 027900 700-MATCH.
  11797. 028000     MOVE VA1X-RCD TO VA1Z-RCD.
  11798. 028100     PERFORM 890-EDIT-DATE.
  11799. 028200     MOVE SORT-RCD TO VA1K-RCD.
  11800. 028300     IF (DATA-1-SR NOT = SPACE) OR
  11801. 028400         (DATA-2-SR NOT = SPACE)
  11802. 028500             PERFORM 850-MOVE-FIELDS
  11803. 028600             PERFORM 810-BUILD-LIN
  11804. 028700             ADD 1 TO VA-CTR
  11805. 028800             PERFORM 920-WRITE-Z.
  11806. 028900     PERFORM 430-RETURN-SORT.
  11807. 029000     PERFORM 440-READ-PREV.
  11808. 029100 810-BUILD-LIN.
  11809. 029200     IF (LIN-NUM-3578-VA1Z NOT NUMERIC) OR
  11810. 029300        (LIN-NUM-3578-VA1Z = "0000")
  11811. 029400             MOVE "9999" TO LIN-NUM-3578-VA1Z.
  11812. 029500 820-CHECK-LIN.
  11813. 029600     IF LIN-NUM-3578-VA1Z NOT = "9999"
  11814. 029700             GO TO 820-OUT.
  11815. 029800     MOVE DIC-VA1Z TO REC-TYP-C.
  11816. 029900     MOVE BLM-ADM-U-0003-VA1Z TO SDRP-C.
  11817. 030000     MOVE ALLOT-PAST-VA1Z TO ALLOT-PAST-C.
  11818. 030100     IF CTL NOT = CTL-SAVE
  11819. 030200             MOVE 0001 TO LAST-LIN-NUM
  11820. 030300             MOVE "0001" TO LIN-NUM-3578-VA1Z  ELSE
  11821. 030400             ADD 1 TO LAST-LIN-NUM
  11822. 030500             MOVE LAST-LIN-NUM TO LIN-NUM-3578-VA1Z.
  11823. 030600     MOVE CTL TO CTL-SAVE.
  11824. 030700 820-OUT.
  11825. 030800     EXIT.
  11826. 030900*
  11827. 031000 850-MOVE-FIELDS.
  11828. 031100     IF MTR-TWNSHP-1695-VA1K = SPACES
  11829. 031200       NEXT SENTENCE
  11830. 031300       ELSE
  11831. 031400       IF MTR-TWNSHP-1695-VA1K = "*****"
  11832. 031500         MOVE SPACES TO MTR-TWNSHP-1695-VA1Z
  11833. 031600         ELSE
  11834. 031700         MOVE MTR-TWNSHP-1695-VA1K TO MTR-TWNSHP-1695-VA1Z.
  11835. 031800     IF MTR-RNG-1699-VA1K = SPACES
  11836. 031900       NEXT SENTENCE
  11837. 032000       ELSE
  11838. 032100       IF MTR-RNG-1699-VA1K = "*****"
  11839. 032200         MOVE SPACES TO MTR-RNG-1699-VA1Z
  11840. 032300         ELSE
  11841. 032400         MOVE MTR-RNG-1699-VA1K TO MTR-RNG-1699-VA1Z.
  11842. 032500     IF SEC-SECT-2506-VA1K = SPACES
  11843. 032600       NEXT SENTENCE
  11844. 032700       ELSE
  11845. 032800       IF SEC-SECT-2506-VA1K = "***"
  11846. 032900         MOVE SPACES TO SEC-SECT-2506-VA1Z
  11847. 033000         ELSE
  11848. 033100         MOVE SEC-SECT-2506-VA1K TO SEC-SECT-2506-VA1Z.
  11849. 033200     IF SWA-3507-VA1K = SPACES
  11850. 033300       NEXT SENTENCE
  11851. 033400       ELSE
  11852. 033500       IF SWA-3507-VA1K = "****"
  11853. 033600         MOVE SPACES TO SWA-3507-VA1Z
  11854. 033700         ELSE
  11855. 033800         MOVE SWA-3507-VA1K TO SWA-3507-VA1Z.
  11856. 033900     IF ALIQ-PART-2904-VA1K (1) = SPACES
  11857. 034000       NEXT SENTENCE
  11858. 034100       ELSE
  11859. 034200       IF ALIQ-PART-2904-VA1K (1) = "****"
  11860. 034300         MOVE SPACES TO ALIQ-PART-2904-VA1Z (1)
  11861. 034400         ELSE
  11862. 034500         MOVE ALIQ-PART-2904-VA1K (1) TO ALIQ-PART-2904-VA1Z (1).
  11863. 034600     IF ALIQ-PART-2904-VA1K (2) = SPACES
  11864. 034700       NEXT SENTENCE
  11865. 034800       ELSE
  11866. 034900       IF ALIQ-PART-2904-VA1K (2) = "****"
  11867. 035000         MOVE SPACES TO ALIQ-PART-2904-VA1Z (2)
  11868. 035100         ELSE
  11869. 035200         MOVE ALIQ-PART-2904-VA1K (2) TO ALIQ-PART-2904-VA1Z (2).
  11870. 035300     IF ALIQ-PART-2904-VA1K (3) = SPACES
  11871. 035400       NEXT SENTENCE
  11872. 035500       ELSE
  11873. 035600       IF ALIQ-PART-2904-VA1K (3) = "****"
  11874. 035700         MOVE SPACES TO ALIQ-PART-2904-VA1Z (3)
  11875. 035800         ELSE
  11876. 035900         MOVE ALIQ-PART-2904-VA1K (3) TO ALIQ-PART-2904-VA1Z (3).
  11877. 036000     IF ALIQ-PART-2904-VA1K (4) = SPACES
  11878. 036100       NEXT SENTENCE
  11879. 036200       ELSE
  11880. 036300       IF ALIQ-PART-2904-VA1K (4) = "****"
  11881. 036400         MOVE SPACES TO ALIQ-PART-2904-VA1Z (4)
  11882. 036500         ELSE
  11883. 036600         MOVE ALIQ-PART-2904-VA1K (4) TO ALIQ-PART-2904-VA1Z (4).
  11884. 036700     IF ACR-DU-6520-OWNR-VA1K = SPACES
  11885. 036800       NEXT SENTENCE
  11886. 036900       ELSE
  11887. 037000*      IF ACR-DU-6520-OWNR-VA1K = "*****"
  11888. 037100       IF ACR-DU-6520-OWNR-VA1K = "00000"
  11889. 037200         MOVE SPACES TO ACR-DU-6520-OWNR-VA1Z
  11890. 037300         ELSE
  11891. 037400         MOVE ACR-DU-6520-OWNR-VA1K TO ACR-DU-6520-OWNR-VA1Z.
  11892. 037500     IF OWN-TYP-2531-VA1K = SPACES
  11893. 037600       NEXT SENTENCE
  11894. 037700       ELSE
  11895. 037800       IF OWN-TYP-2531-VA1K = "****"
  11896. 037900         MOVE SPACES TO OWN-TYP-2531-VA1Z
  11897. 038000         ELSE
  11898. 038100         MOVE OWN-TYP-2531-VA1K TO OWN-TYP-2531-VA1Z.
  11899. 038200     IF JURIS-2572-VA1K = SPACES
  11900. 038300       NEXT SENTENCE
  11901. 038400       ELSE
  11902. 038500       IF JURIS-2572-VA1K = "****"
  11903. 038600         MOVE SPACES TO JURIS-2572-VA1Z
  11904. 038700         ELSE
  11905. 038800         MOVE JURIS-2572-VA1K TO JURIS-2572-VA1Z.
  11906. 038900     IF MGT-ADM-2570-VA1K = SPACES
  11907. 039000       NEXT SENTENCE
  11908. 039100       ELSE
  11909. 039200       IF MGT-ADM-2570-VA1K = "****"
  11910. 039300         MOVE SPACES TO MGT-ADM-2570-VA1Z
  11911. 039400         ELSE
  11912. 039500         MOVE MGT-ADM-2570-VA1K TO MGT-ADM-2570-VA1Z.
  11913. 039600     IF LAND-TYP-3801-VA1K = SPACES
  11914. 039700       NEXT SENTENCE
  11915. 039800       ELSE
  11916. 039900       IF LAND-TYP-3801-VA1K = "****"
  11917. 040000         MOVE SPACES TO LAND-TYP-3801-VA1Z
  11918. 040100         ELSE
  11919. 040200         MOVE LAND-TYP-3801-VA1K TO LAND-TYP-3801-VA1Z.
  11920. 040300 890-EDIT-DATE.
  11921. 040400     MOVE SPACE TO DATE-MV-SW.
  11922. 040500     MOVE DATA-DATE-6618-VA1Z TO DATE-WORK.
  11923. 040600     PERFORM 900-EDIT-FIELDS.
  11924. 040700     IF DATE-SW NOT = " "
  11925. 040800             PERFORM 910-SWITCH-FIELDS
  11926. 040900             PERFORM 900-EDIT-FIELDS.
  11927. 041000     IF DATE-SW NOT = " "
  11928. 041100             MOVE TODAYS-DATE TO DATA-DATE-6618-VA1Z.
  11929. 041200     IF DATE-MV-SW NOT = " "
  11930. 041300             MOVE MOVED-DATE TO DATA-DATE-6618-VA1Z.
  11931. 041400 900-EDIT-FIELDS.
  11932. 041500     MOVE SPACE TO DATE-SW.
  11933. 041600     IF DW-MM NOT NUMERIC OR
  11934. 041700        DW-MM > "12"      OR
  11935. 041800        DW-MM < "01"
  11936. 041900             MOVE "X" TO DATE-SW.
  11937. 042000     IF DW-DD NOT NUMERIC OR
  11938. 042100        DW-DD > "31"      OR
  11939. 042200        DW-DD < "01"
  11940. 042300             MOVE "X" TO DATE-SW.
  11941. 042400     IF DW-YY NOT NUMERIC OR
  11942. 042500        DW-YY < "78"
  11943. 042600             MOVE "X" TO DATE-SW.
  11944. 042700 910-SWITCH-FIELDS.
  11945. 042800     MOVE " " TO DATE-MV-SW.
  11946. 042900     IF DW-DD = "78" OR "79" OR "80" OR "81" OR "82"
  11947. 043000             MOVE DW-MM TO MD-MM
  11948. 043100             MOVE DW-DD TO MD-DD
  11949. 043200             MOVE DW-YY TO MD-YY
  11950. 043300             MOVE "X"   TO DATE-MV-SW.
  11951. 043400 920-WRITE-Z.
  11952. 043500     MOVE LIN-NUM-3578-VA1Z TO LAST-LIN-NUM.
  11953. 043600     MOVE DIC-VA1Z TO REC-TYP-C.
  11954. 043700     MOVE BLM-ADM-U-0003-VA1Z TO SDRP-C.
  11955. 043800     MOVE ALLOT-PAST-VA1Z TO ALLOT-PAST-C.
  11956. 043900     MOVE CTL TO CTL-SAVE.
  11957. 044000     MOVE SPACE TO OPEN-VA1Z.
  11958. 044100     MOVE "A" TO ACTN-CD-7350-VA1Z.
  11959. 044200     WRITE VA1Z-RCD.
  11960. 044300 400-EXIT.
  11961. 044400     EXIT.
  11962. 044500*
  11963. 044600 990-TERMINATE SECTION.
  11964. 044700 990-PRINT.
  11965. 044800     DISPLAY "VA RCDS"
  11966. 044900     DISPLAY " " VA-CTR.
  11967. 045000 990-CLOSE.
  11968. 045100     CLOSE TRAN-FILE PREV-FILE NEW-FILE.
  11969. 000000*-----------------------------------------------------------------
  11970. 000100 IDENTIFICATION DIVISION.
  11971. 000200 PROGRAM-ID. ES215P.
  11972. 000300*        VA VERIFICATION LIST
  11973. 000400*
  11974. 000500 AUTHOR. CORA FISCHER.
  11975. 000600 INSTALLATION.
  11976. 000700 DATE-WRITTEN.  7/21/80.
  11977. 000800 DATE-COMPILED.
  11978. 000900 ENVIRONMENT DIVISION.
  11979. 001000 CONFIGURATION SECTION.
  11980. 001100 SOURCE-COMPUTER. LEVEL-66-ASCII.
  11981. 001200 OBJECT-COMPUTER. LEVEL-66-ASCII.
  11982. 001300 INPUT-OUTPUT SECTION.
  11983. 001400 FILE-CONTROL.
  11984. 001500     SELECT  INPUT-FILE1 ASSIGN TO I1-ES210UD1
  11985. 001600         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  11986. 001700     SELECT  PRINT-FILE ASSIGN TO P1-PRINTER
  11987. 001800         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  11988. 001900     SELECT  SORT-FILE ASSIGN TO S1.
  11989. 002000 DATA DIVISION.
  11990. 002100 SUB-SCHEMA SECTION.
  11991. 002200 DB  CODVAL2 WITHIN BLMDIC.
  11992. 002300 FILE SECTION.
  11993. 002400 FD  INPUT-FILE1       CODE-SET IS GBCD
  11994. 002500                       LABEL RECORDS ARE STANDARD
  11995. 002600                       DATA RECORD IS FDR-VA.
  11996. 002700 01  FDR-VA.
  11997. 002800     03  REC-TYPE-3529-VA-I1               PIC       X(02).
  11998. 002900     03  FMT-NO-3576-VA-I1                 PIC       X(01).
  11999. 003000     03  FMT-CD-3579-VA-I1                 PIC       X(01).
  12000. 003100     03  ADM-UNIT-0003-VA-I1               PIC       X(08).
  12001. 003200     03  ALLOT-NUM-0968-VA-I1              PIC       X(04).
  12002. 003300     03  PASTURE-NUM-3905-VA-I1            PIC       X(02).
  12003. 003400     03  DATA-DT-6618-VA-I1                PIC       X(06).
  12004. 003500     03  ACT-CD-7350-VA-I1                 PIC       X(01).
  12005. 003600     03  MAP-SRC-3540-VA-I1                PIC       X(04).
  12006. 003700     03  MTR-MER-CD-1703-VA-I1             PIC       X(02).
  12007. 003800     03  LINE-NO-3578-VA-I1                PIC       X(04).
  12008. 003900     03  MTR-TWNSHIP-1695-VA-I1            PIC       X(05).
  12009. 004000     03  MTR-RNG-1699-VA-I1                PIC       X(05).
  12010. 004100     03  SEC-SECT-2506-VA-I1               PIC       X(03).
  12011. 004200     03  SWA-3507-VA-I1                    PIC       X(04).
  12012. 004300     03  ALIQ-PART-2904-VA-I1    PIC       X(04)  OCCURS 4 TIMES.
  12013. 004400     03  ACR-DU-6520-VA-I1                 PIC       X(05).
  12014. 004500     03  OWN-TYP-2531-VA-I1                PIC       X(04).
  12015. 004600     03  JURIS-2572-VA-I1                  PIC       X(04).
  12016. 004700     03  MGT-ADM-2570-VA-I1                PIC       X(04).
  12017. 004800     03  LAND-TYP-3801-VA-I1               PIC       X(04).
  12018. 004900 FD  PRINT-FILE        CODE-SET IS GBCD
  12019. 005000                       LABEL RECORDS ARE STANDARD
  12020. 005100                       DATA RECORD IS PRT-REC.
  12021. 005200 01  PRT-REC                               PIC       X(132).
  12022. 005300 SD  SORT-FILE         DATA RECORDS IS S-KEY1.
  12023. 005400 01  S-KEY1.
  12024. 005500     03  REC-TYPE-3529-VA-S1               PIC       X(02).
  12025. 005600     03  FMT-NO-3576-VA-S1                 PIC       X(01).
  12026. 005700     03  FMT-CD-3579-VA-S1                 PIC       X(01).
  12027. 005800     03  ADM-UNIT-0003-VA-S1.
  12028. 005900         05  ADM-ST-0003-VA-S1             PIC       X(02).
  12029. 006000         05  ADM-DI-0003-VA-S1             PIC       X(02).
  12030. 006100         05  ADM-RA-0003-VA-S1             PIC       X(02).
  12031. 006200         05  ADM-PU-0003-VA-S1             PIC       X(02).
  12032. 006300     03  ALLOT-NUM-0968-VA-S1              PIC       X(04).
  12033. 006400     03  PASTURE-NUM-3905-VA-S1            PIC       X(02).
  12034. 006500     03  DATA-DT-6618-VA-S1                PIC       X(06).
  12035. 006600     03  ACT-CD-7350-VA-S1                 PIC       X(01).
  12036. 006700     03  MAP-SRC-3540-VA-S1                PIC       X(04).
  12037. 006800     03  MTR-MER-CD-1703-VA-S1             PIC       X(02).
  12038. 006900     03  LINE-NO-3578-VA-S1                PIC       X(04).
  12039. 007000     03  MTR-TWNSHIP-1695-VA-S1.
  12040. 007100         05  NUM-1695-VA-S1               PIC        999V9.
  12041. 007200         05  DIR-1695-VA-S1               PIC        X(01).
  12042. 007300     03  MTR-RNG-1699-VA-S1.
  12043. 007400         05  NUM-1699-VA-S1               PIC        999V9.
  12044. 007500         05  DIR-1699-VA-S1               PIC        X(01).
  12045. 007600     03  SEC-SECT-2506-VA-S1               PIC       X(03).
  12046. 007700     03  SWA-3507-VA-S1                    PIC       X(04).
  12047. 007800     03  ALIQ-PART-2904-VA-S1    PIC       X(04)  OCCURS 4 TIMES.
  12048. 007900     03  ACR-DU-6520-VA-S1                 PIC       X(05).
  12049. 008000     03  OWN-TYP-2531-VA-S1                PIC       X(04).
  12050. 008100     03  JURIS-2572-VA-S1                  PIC       X(04).
  12051. 008200     03  MGT-ADM-2570-VA-S1                PIC       X(04).
  12052. 008300     03  LAND-TYP-3801-VA-S1               PIC       X(04).
  12053. 008400 WORKING-STORAGE SECTION.
  12054. 008500 77  PAGE-CNT                    PIC       9(05)     VALUE 0.
  12055. 008600 77  VA-CNT                      PIC       9(07)     VALUE 0.
  12056. 008700 77  LINE-CNT                    PIC       9(02)     VALUE 66.
  12057. 008800 01  MONTH-TABLE.
  12058. 008900     03  MO-TAB.
  12059. 009000         05  FILLER              PIC       X(03)     VALUE "JAN".
  12060. 009100         05  FILLER              PIC       X(03)     VALUE "FEB".
  12061. 009200         05  FILLER              PIC       X(03)     VALUE "MAR".
  12062. 009300         05  FILLER              PIC       X(03)     VALUE "APR".
  12063. 009400         05  FILLER              PIC       X(03)     VALUE "MAY".
  12064. 009500         05  FILLER              PIC       X(03)     VALUE "JUN".
  12065. 009600         05  FILLER              PIC       X(03)     VALUE "JUL".
  12066. 009700         05  FILLER              PIC       X(03)     VALUE "AUG".
  12067. 009800         05  FILLER              PIC       X(03)     VALUE "SEP".
  12068. 009900         05  FILLER              PIC       X(03)     VALUE "OCT".
  12069. 010000         05  FILLER              PIC       X(03)     VALUE "NOV".
  12070. 010100         05  FILLER              PIC       X(03)     VALUE "DEC".
  12071. 010200     03  MON REDEFINES MO-TAB    PIC       X(03) OCCURS 12 TIMES.
  12072. 010300 01  EOF-SWITCH                  PIC       9   VALUE 0.
  12073. 010400     88  EOF                               VALUE  1.
  12074. 010500 01  EOR-SWITCH                  PIC       9   VALUE  0.
  12075. 010600     88  EOR                               VALUE 1.
  12076. 010700 01  PARAMETER                   PIC       X(04).
  12077. 010800 01  HLD-DT.
  12078. 010900     03  HOLD-DT.
  12079. 011000         05  YR-DT               PIC       X(02).
  12080. 011100         05  MO-DT               PIC       9(02).
  12081. 011200         05  DY-DT               PIC       X(02).
  12082. 011300     03  INV-HLD.
  12083. 011400         05  INV-NM    PIC       X(20).
  12084. 011500         05  ST-DIST-CD.
  12085. 011600             07  ST-CD-HLD       PIC       X(02).
  12086. 011700             07  DI-CD-HLD       PIC       X(02).
  12087. 011800     03  EXPL-HLD.
  12088. 011900         05  DIST-NM-HLD         PIC       X(12).
  12089. 012000     03  FUNC-HLD.
  12090. 012100         05  ST-NM-HLD           PIC       X(10).
  12091. 012200         05  FILLER              PIC       X(14).
  12092. 012300     COPY DBSTATUS IN TPCOBOLIB.
  12093. 012400 01  HDR-1.
  12094. 012500     03  FILLER                  PIC       X(08)     VALUE
  12095. 012600         " DATE:  ".
  12096. 012700     03  HDR-MO                  PIC       X(03).
  12097. 012800     03  FILLER                  PIC       X(01)     VALUE SPACE.
  12098. 012900     03  HDR-DA                  PIC       X(02).
  12099. 013000     03  FILLER                  PIC       X(04)     VALUE ", 19".
  12100. 013100     03  HDR-YR                  PIC       X(02).
  12101. 013200     03  FILLER                  PIC       X(21)     VALUE SPACES.
  12102. 013300     03  FILLER                  PIC       X(47)     VALUE
  12103. 013400         "US DEPT OF INTERIOR - BUREAU OF LAND MANAGEMENT".
  12104. 013500     03  FILLER                  PIC       X(29)     VALUE SPACES.
  12105. 013600     03  FILLER                  PIC       X(07)     VALUE
  12106. 013700         "PAGE:  ".
  12107. 013800     03  HDR-PG                  PIC       ZZ,ZZ9.
  12108. 013900     03  FILLER                  PIC       X(02)     VALUE SPACES.
  12109. 014000 01  HDR-2.
  12110. 014100     03  FILLER                  PIC       X(8)      VALUE
  12111. 014200         "STATE:  ".
  12112. 014300     03  HDR-ST-CD               PIC       X(02).
  12113. 014400     03  FILLER                  PIC       X(04)     VALUE SPACES.
  12114. 014500     03  HDR-ST-NM                         PIC       X(10).
  12115. 014600     03  FILLER                  PIC       X(30)     VALUE SPACES.
  12116. 014700     03  FILLER                  PIC       X(25)     VALUE
  12117. 014800         "ECOLOGICAL SITE INVENTORY".
  12118. 014900     03  FILLER                  PIC       X(35)     VALUE SPACES.
  12119. 015000     03  FILLER                  PIC       X(18)     VALUE
  12120. 015100         "PROGRAM:  ES215P  ".
  12121. 015200 01  HDR-3.
  12122. 015300     03  FILLER                  PIC       X(08)     VALUE
  12123. 015400         "   DI:  ".
  12124. 015500     03  HDR-DIST-CD             PIC       X(02).
  12125. 015600     03  FILLER                  PIC       X(04)     VALUE SPACES.
  12126. 015700     03  HDR-DIST-NM             PIC       X(25).
  12127. 015800     03  FILLER                  PIC       X(79)     VALUE SPACES.
  12128. 015900     03  FILLER                  PIC       X(14)     VALUE
  12129. 016000         "PCN:  SV215P  ".
  12130. 016100 01  HDR-4.
  12131. 016200     03  FILLER                  PIC       X(08)     VALUE
  12132. 016300         "  INV:  ".
  12133. 016400     03  HDR-INV-CD              PIC       X(04).
  12134. 016500     03  FILLER                  PIC       X(02)     VALUE SPACES.
  12135. 016600     03  HDR-INV-NM              PIC       X(25).
  12136. 016700     03  FILLER                  PIC       X(16)     VALUE SPACES.
  12137. 016800     03  HDR-REC-TYPE            PIC       X(02).
  12138. 016900     03  FILLER                  PIC       X(18)     VALUE
  12139. 017000         " VERIFICATION LIST".
  12140. 017100     03  FILLER                  PIC       X(57)     VALUE SPACES.
  12141. 017200 01  HDR-5-VA.
  12142. 017300     03  FILLER                  PIC       X(52)     VALUE
  12143. 017400        "(1-2)        (3)        (4)   (5)   (6) (7)  (8) (9)".
  12144. 017500     03  FILLER                  PIC       X(08)     VALUE SPACES.
  12145. 017600     03  FILLER                  PIC       X(51)     VALUE
  12146. 017700         "(10)   (11)  (12)  (13)  NE4 NW4(14)SW4  SE4  (15) ".
  12147. 017800     03  FILLER                  PIC       X(21)     VALUE
  12148. 017900         "(16) (17)  (18)  (19)".
  12149. 018000 01  HDR-6-VA.
  12150. 018100     03  FILLER                  PIC       X(20)     VALUE
  12151. 018200         " REC     ADMIN  UNIT".
  12152. 018300     03  FILLER                  PIC       X(15)    VALUE SPACES.
  12153. 018400     03  FILLER                  PIC       X(36)     VALUE
  12154. 018500         "DATE ACT  MAP     LINE   TWP   RANGE".
  12155. 018600     03  FILLER                  PIC       X(08)     VALUE SPACES.
  12156. 018700     03  FILLER                  PIC       X(41)     VALUE
  12157. 018800         "SWA  NNSS NNSS  NNSS NNSS       SURF FED ".
  12158. 018900     03  FILLER                  PIC       X(12)     VALUE
  12159. 019000         "SUR ONLY TYP".
  12160. 019100 01  HDR-7-VA.
  12161. 019200     03  FILLER                  PIC       X(54)     VALUE
  12162. 019300        "TYPE ST  DI   RA   PU  ALLOT PAST YYMMDD CD  SRC MER  ".
  12163. 019400     03  FILLER                  PIC       X(51)     VALUE
  12164. 019500         "NUM NUM FD NUM FD  SEC   NUM  EWWE EWWE  EWWE EWWE ".
  12165. 019600     03  FILLER                  PIC       X(27)     VALUE
  12166. 019700         "ACRES OWNR JURIS ADMIN  LND".
  12167. 019800 01  HDR-8-VA.
  12168. 019900     03  FILLER                  PIC       X(53)     VALUE
  12169. 020000         " 1-4 5-6 7-8 9-10 11-2 13-16 17-8 19-24  25 26-9  30 ".
  12170. 020100     03  FILLER                  PIC       X(52)     VALUE
  12171. 020200         "32-35 36-40  41-45 46-48 49-52 53-6 57-60 61-4 65-8 ".
  12172. 020300     03  FILLER                  PIC       X(27)     VALUE
  12173. 020400         "69-73 74-7 78-81 82-85 86-9".
  12174. 020500 01  HDR-9-VA.
  12175. 020600     03  FILLER                  PIC       X(53)     VALUE
  12176. 020700         "XXXX XX  XX   XX   XX  XXXX   XX  XXXXXX  X XXXX  XX ".
  12177. 020800     03  FILLER                  PIC       X(52)     VALUE
  12178. 020900         "9999 999.9X 999.9X  999  XXXX  XXXX XXXX  XXXX XXXX ".
  12179. 021000     03  FILLER                  PIC       X(27)     VALUE
  12180. 021100         "99999 XXXX XXXX  XXXX  XXXX".
  12181. 021200 01  HDR-10-DET-VA.
  12182. 021300     03  REC-TYPE-3529-VA-P1     PIC       X(02).
  12183. 021400     03  FMT-NO-3576-VA-P1       PIC       X(01).
  12184. 021500     03  FMT-CD-3579-VA-P1       PIC       X(01).
  12185. 021600     03  FILLER                  PIC       X(01)     VALUE SPACE.
  12186. 021700     03  ADM-ST-0003-VA-P1       PIC       X(02).
  12187. 021800     03  FILLER                  PIC       X(02)     VALUE SPACES.
  12188. 021900     03  ADM-DI-0003-VA-P1       PIC       X(02).
  12189. 022000     03  FILLER                  PIC       X(03)     VALUE SPACES.
  12190. 022100     03  ADM-RA-0003-VA-P1       PIC       X(02).
  12191. 022200     03  FILLER                  PIC       X(03)     VALUE SPACES.
  12192. 022300     03  ADM-PU-0003-VA-P1       PIC       X(02).
  12193. 022400     03  FILLER                  PIC       X(02)     VALUE SPACES.
  12194. 022500     03  ALLOT-NUM-0968-VA-P1    PIC       X(04).
  12195. 022600     03  FILLER                  PIC       X(03)     VALUE SPACES.
  12196. 022700     03  PASTURE-NUM-3905-VA-P1  PIC       X(02).
  12197. 022800     03  FILLER                  PIC       X(02)     VALUE SPACES.
  12198. 022900     03  DATA-DT-6618-VA-P1      PIC       X(06).
  12199. 023000     03  FILLER                  PIC       X(02)     VALUE SPACES.
  12200. 023100     03  ACT-CD-7350-VA-P1       PIC       X(01).
  12201. 023200     03  FILLER                  PIC       X(01)     VALUE SPACE.
  12202. 023300     03  MAP-SRC-3540-VA-P1      PIC       X(04).
  12203. 023400     03  FILLER                  PIC       X(02)    VALUE SPACES.
  12204. 023500     03  MTR-MER-CD-1703-VA-P1   PIC       X(02).
  12205. 023600     03  FILLER                  PIC       X(01)     VALUE SPACE.
  12206. 023700     03  LINE-NO-3578-VA-P1      PIC       9(04).
  12207. 023800     03  FILLER                  PIC       X(01)     VALUE SPACE.
  12208. 023900     03  MTR-TWNSHIP-1695-VA-P1.
  12209. 024000         05  NUM-1695-VA-P1      PIC       999.9.
  12210. 024100         05  DIR-1695-VA-P1      PIC       X(01).
  12211. 024200     03  FILLER                  PIC       X(01)   VALUE SPACE.
  12212. 024300     03  MTR-RNG-1699-VA-P1.
  12213. 024400         05  NUM-1699-VA-P1      PIC       999.9.
  12214. 024500         05  DIR-1699-VA-P1      PIC       X(01).
  12215. 024600     03  FILLER                  PIC       X(02)     VALUE SPACES.
  12216. 024700     03  SEC-SECT-2506-VA-P1     PIC       X(03).
  12217. 024800     03  FILLER                  PIC       X(02)     VALUE SPACES.
  12218. 024900     03  SWA-3507-VA-P1          PIC       X(04).
  12219. 025000     03  FILLER                  PIC       X(02)     VALUE SPACES.
  12220. 025100     03  ALIQ-PART1-2904-VA-P1    PIC       X(04).
  12221. 025200     03  FILLER                  PIC       X(01)     VALUE SPACE.
  12222. 025300     03  ALIQ-PART2-2904-VA-P1    PIC       X(04).
  12223. 025400     03  FILLER                   PIC       X(02)    VALUE SPACES.
  12224. 025500     03  ALIQ-PART3-2904-VA-P1    PIC       X(04).
  12225. 025600     03  FILLER                   PIC       X(01)    VALUE SPACE.
  12226. 025700     03  ALIQ-PART4-2904-VA-P1    PIC       X(04).
  12227. 025800     03  FILLER                   PIC       X(01)    VALUE SPACE.
  12228. 025900     03  ACR-DU-6520-VA-P1       PIC       9(05).
  12229. 026000     03  FILLER                  PIC       X(01)     VALUE SPACE.
  12230. 026100     03  OWN-TYP-2531-VA-P1      PIC       X(04).
  12231. 026200     03  FILLER                  PIC       X(01)     VALUE SPACE.
  12232. 026300     03  JURIS-2572-VA-P1        PIC       X(04).
  12233. 026400     03  FILLER                  PIC       X(02)     VALUE SPACES.
  12234. 026500     03  MGT-ADM-2570-VA-P1      PIC       X(04).
  12235. 026600     03  FILLER                  PIC       X(02)     VALUE SPACES.
  12236. 026700     03  LAND-TYP-3801-VA-P1     PIC       X(04).
  12237. 026800 PROCEDURE DIVISION.
  12238. 026900 START-SORT SECTION.
  12239. 027000 100-SORT.
  12240. 027100             SORT SORT-FILE ON ASCENDING REC-TYPE-3529-VA-S1
  12241. 027200         FMT-NO-3576-VA-S1 FMT-CD-3579-VA-S1 ADM-UNIT-0003-VA-S1
  12242. 027300         ALLOT-NUM-0968-VA-S1  PASTURE-NUM-3905-VA-S1
  12243. 027400         SWA-3507-VA-S1  MTR-MER-CD-1703-VA-S1
  12244. 027500         MTR-RNG-1699-VA-S1  MTR-TWNSHIP-1695-VA-S1
  12245. 027600         SEC-SECT-2506-VA-S1
  12246. 027700     INPUT PROCEDURE PRE-SORT
  12247. 027800     OUTPUT PROCEDURE POST-SORT.
  12248. 027900 200-END-SECTION.
  12249. 028000     FINISH DIC-DE.
  12250. 028100     DISPLAY "VA-CNT"  VA-CNT.
  12251. 028200     CLOSE PRINT-FILE.
  12252. 028300     STOP RUN.
  12253. 028400 PRE-SORT SECTION.
  12254. 028500 300-HSKPNG.
  12255. 028600     OPEN INPUT INPUT-FILE1.
  12256. 028700     MOVE SPACES TO S-KEY1.
  12257. 028800 400-MAIN.
  12258. 028900     PERFORM 500-RD-FILE THRU 600-EXIT-RD UNTIL EOF.
  12259. 029000     CLOSE INPUT-FILE1.
  12260. 029100     GO TO 600-EXIT-RD.
  12261. 029200 500-RD-FILE.
  12262. 029300     READ INPUT-FILE1  AT END MOVE 1 TO EOF-SWITCH.
  12263. 029400     IF  (EOF-SWITCH = 1)  GO TO 600-EXIT-RD.
  12264. 029500     ADD 1 TO VA-CNT.
  12265. 029600     MOVE FDR-VA TO S-KEY1.
  12266. 029700     RELEASE S-KEY1.
  12267. 029800 600-EXIT-RD.
  12268. 029900     EXIT.
  12269. 030000 POST-SORT SECTION.
  12270. 030100 3050-RET-HSKPNG.
  12271. 030200     OPEN OUTPUT PRINT-FILE.
  12272. 030300     ACCEPT  PARAMETER.
  12273. 030400     ACCEPT  HOLD-DT FROM DATE.
  12274. 030500     MOVE YR-DT TO HDR-YR.
  12275. 030600     MOVE MON(MO-DT) TO HDR-MO.
  12276. 030700     MOVE DY-DT TO HDR-DA.
  12277. 030800     READY DIC-DE.
  12278. 030900     PERFORM 4000-VALIDATE-INV THRU 4050-EXIT-STDI.
  12279. 031000     RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH.
  12280. 031100 3060-MAIN-DRIVER.
  12281. 031200     PERFORM 4300-PRT-DET THRU 4360-EXIT-RET UNTIL EOR.
  12282. 031300     GO TO 5000-DUMMY.
  12283. 031400 4300-PRT-DET.
  12284. 031500     IF  LINE-CNT > 50
  12285. 031600         PERFORM 4200-PRT-HDNG.
  12286. 031700     MOVE REC-TYPE-3529-VA-S1 TO REC-TYPE-3529-VA-P1.
  12287. 031800     MOVE FMT-NO-3576-VA-S1 TO FMT-NO-3576-VA-P1.
  12288. 031900     MOVE FMT-CD-3579-VA-S1  TO  FMT-CD-3579-VA-P1.
  12289. 032000     MOVE ADM-ST-0003-VA-S1      TO  ADM-ST-0003-VA-P1.
  12290. 032100     MOVE ADM-DI-0003-VA-S1      TO  ADM-DI-0003-VA-P1.
  12291. 032200     MOVE ADM-RA-0003-VA-S1      TO  ADM-RA-0003-VA-P1.
  12292. 032300     MOVE ADM-PU-0003-VA-S1      TO  ADM-PU-0003-VA-P1.
  12293. 032400     MOVE ALLOT-NUM-0968-VA-S1   TO  ALLOT-NUM-0968-VA-P1.
  12294. 032500     MOVE PASTURE-NUM-3905-VA-S1  TO  PASTURE-NUM-3905-VA-P1.
  12295. 032600     MOVE DATA-DT-6618-VA-S1     TO  DATA-DT-6618-VA-P1.
  12296. 032700     MOVE ACT-CD-7350-VA-S1      TO  ACT-CD-7350-VA-P1.
  12297. 032800     MOVE MAP-SRC-3540-VA-S1     TO  MAP-SRC-3540-VA-P1.
  12298. 032900     MOVE MTR-MER-CD-1703-VA-S1  TO  MTR-MER-CD-1703-VA-P1.
  12299. 033000     MOVE LINE-NO-3578-VA-S1     TO  LINE-NO-3578-VA-P1.
  12300. 033100     MOVE NUM-1695-VA-S1  TO  NUM-1695-VA-P1.
  12301. 033200     MOVE DIR-1695-VA-S1  TO  DIR-1695-VA-P1.
  12302. 033300     MOVE NUM-1699-VA-S1  TO  NUM-1699-VA-P1.
  12303. 033400     MOVE DIR-1699-VA-S1  TO  DIR-1699-VA-P1.
  12304. 033500     MOVE SEC-SECT-2506-VA-S1          TO  SEC-SECT-2506-VA-P1.
  12305. 033600     MOVE SWA-3507-VA-S1         TO  SWA-3507-VA-P1.
  12306. 033700     MOVE ALIQ-PART-2904-VA-S1 (1) TO  ALIQ-PART1-2904-VA-P1.
  12307. 033800     MOVE ALIQ-PART-2904-VA-S1 (2) TO  ALIQ-PART2-2904-VA-P1.
  12308. 033900     MOVE ALIQ-PART-2904-VA-S1 (3) TO  ALIQ-PART3-2904-VA-P1.
  12309. 034000     MOVE ALIQ-PART-2904-VA-S1 (4) TO  ALIQ-PART4-2904-VA-P1.
  12310. 034100     MOVE ACR-DU-6520-VA-S1      TO  ACR-DU-6520-VA-P1.
  12311. 034200     MOVE OWN-TYP-2531-VA-S1     TO  OWN-TYP-2531-VA-P1.
  12312. 034300     MOVE JURIS-2572-VA-S1       TO  JURIS-2572-VA-P1.
  12313. 034400     MOVE MGT-ADM-2570-VA-S1     TO  MGT-ADM-2570-VA-P1.
  12314. 034500     MOVE LAND-TYP-3801-VA-S1    TO  LAND-TYP-3801-VA-P1.
  12315. 034600     WRITE PRT-REC FROM HDR-10-DET-VA AFTER ADVANCING 2 LINES.
  12316. 034700     ADD 2 TO LINE-CNT.
  12317. 034800 4350-RET-SORT.
  12318. 034900     RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH.
  12319. 035000     IF (EOR-SWITCH = 1)  GO TO 4360-EXIT-RET.
  12320. 035100 4360-EXIT-RET.
  12321. 035200     EXIT.
  12322. 035300 4000-VALIDATE-INV.
  12323. 035400     MOVE PARAMETER TO DE-CD-8822-DEC  HDR-INV-CD.
  12324. 035500     MOVE 3940 TO DE-NO-8801-DEC.
  12325. 035600     FIND ANY CODE-DEC.
  12326. 035700     MOVE DB-STATUS TO DB-STAT.
  12327. 035800     IF  NOT OK
  12328. 035900         MOVE "UNKNOWN" TO HDR-ST-NM HDR-DIST-NM HDR-INV-NM
  12329. 036000         GO  TO 4050-EXIT-STDI.
  12330. 036100     GET CODE-DEC.
  12331. 036200     MOVE DB-STATUS TO DB-STAT.
  12332. 036300     IF  NOT OK
  12333. 036400         DISPLAY "ES115PBD   DIDN'T GET INVN"
  12334. 036500         DISPLAY DB-STAT
  12335. 036600         GO  TO 4050-EXIT-STDI.
  12336. 036700     MOVE DE-CD-NAM-8823-DEC TO INV-HLD.
  12337. 036800     MOVE INV-NM TO HDR-INV-NM.
  12338. 036900 4005-VALIDATE-ST.
  12339. 037000     MOVE ST-CD-HLD TO DE-CD-8822-DEC  HDR-ST-CD.
  12340. 037100     MOVE 0003 TO DE-NO-8801-DEC.
  12341. 037200     FIND ANY CODE-DEC.
  12342. 037300     MOVE DB-STATUS TO DB-STAT.
  12343. 037400     IF NOT OK
  12344. 037500         MOVE "UNKNOWN" TO HDR-ST-NM
  12345. 037600         GO TO 4008-EXIT-ST.
  12346. 037700     GET CODE-DEC.
  12347. 037800     MOVE DB-STATUS TO DB-STAT.
  12348. 037900     IF NOT OK
  12349. 038000         DISPLAY "ES115PBD  3  DIDN'T GET ST"
  12350. 038100         DISPLAY "ES115PBD  4  " DB-STAT
  12351. 038200         GO TO 4008-EXIT-ST.
  12352. 038300     MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
  12353. 038400     MOVE ST-NM-HLD TO HDR-ST-NM.
  12354. 038500 4008-EXIT-ST.
  12355. 038600     EXIT.
  12356. 038700 4010-VALIDATE-STDI.
  12357. 038800     MOVE ST-DIST-CD TO DE-CD-8822-DEC.
  12358. 038900    MOVE DI-CD-HLD TO HDR-DIST-CD.
  12359. 039000     MOVE 0003 TO DE-NO-8801-DEC.
  12360. 039100     FIND ANY CODE-DEC.
  12361. 039200     MOVE DB-STATUS TO DB-STAT.
  12362. 039300     IF  NOT OK
  12363. 039400         MOVE "UNKNOWN" TO HDR-DIST-NM
  12364. 039500         GO  TO 4050-EXIT-STDI.
  12365. 039600     GET CODE-DEC.
  12366. 039700     MOVE DB-STATUS TO DB-STAT.
  12367. 039800     IF  NOT OK
  12368. 039900         DISPLAY "ES115PBD 5 DIDN'T GET STDI"
  12369. 040000         DISPLAY  "ES115PBD 6 " DB-STAT
  12370. 040100         GO  TO 4050-EXIT-STDI.
  12371. 040200     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  12372. 040300     MOVE DB-STATUS TO DB-STAT.
  12373. 040400     IF  NOT OK
  12374. 040500         MOVE "UNKNOWN" TO HDR-DIST-NM
  12375. 040600         GO  TO 4050-EXIT-STDI.
  12376. 040700     GET CODE-EXPL-DECE.
  12377. 040800     MOVE DB-STATUS TO DB-STAT.
  12378. 040900     IF  NOT OK
  12379. 041000         DISPLAY "ES115PBD  7 DIDN'T GET DIST"
  12380. 041100         DISPLAY  "ES115PBD 8  " DB-STAT
  12381. 041200         GO  TO 4050-EXIT-STDI.
  12382. 041300     MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD.
  12383. 041400     MOVE DIST-NM-HLD TO HDR-DIST-NM.
  12384. 041500 4050-EXIT-STDI.
  12385. 041600     EXIT.
  12386. 041700 4200-PRT-HDNG.
  12387. 041800     MOVE "VA" TO HDR-REC-TYPE.
  12388. 041900     ADD 1 TO PAGE-CNT.
  12389. 042000     MOVE  PAGE-CNT TO HDR-PG.
  12390. 042100     WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
  12391. 042200     WRITE PRT-REC FROM HDR-2 AFTER ADVANCING 1 LINES.
  12392. 042300     WRITE PRT-REC FROM HDR-3 AFTER ADVANCING 1 LINES.
  12393. 042400     WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES.
  12394. 042500     WRITE PRT-REC FROM HDR-5-VA AFTER ADVANCING 2 LINES.
  12395. 042600     WRITE PRT-REC FROM HDR-6-VA AFTER ADVANCING 1 LINES.
  12396. 042700     WRITE PRT-REC FROM HDR-7-VA AFTER ADVANCING 1 LINES.
  12397. 042800     WRITE PRT-REC FROM HDR-8-VA AFTER ADVANCING 1 LINES.
  12398. 042900     WRITE PRT-REC FROM HDR-9-VA AFTER ADVANCING 1 LINES.
  12399. 043000     MOVE SPACES TO PRT-REC.
  12400. 043100     WRITE PRT-REC AFTER ADVANCING 1 LINES.
  12401. 043200     MOVE 10 TO LINE-CNT.
  12402. 043300 4350-END-RET.
  12403. 043400    EXIT.
  12404. 043500 DUMMY-SECTION.
  12405. 043600 5000-DUMMY.
  12406. 043700     EXIT.
  12407. 043800 END-OF-JOB.
  12408. 000000*-----------------------------------------------------------------
  12409. 000100 IDENTIFICATION DIVISION.
  12410. 000200 PROGRAM-ID. ES220E.
  12411. 000300*        VA EDIT UPDATE
  12412. 000400*
  12413. 000500 AUTHOR. FRANK WILEY.
  12414. 000600 DATE-WRITTEN.  05 SEP 79.
  12415. 000700 DATE-COMPILED.
  12416. 000800 ENVIRONMENT DIVISION.
  12417. 000900 CONFIGURATION SECTION.
  12418. 001000 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  12419. 001100 OBJECT-COMPUTER.  LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
  12420. 001200 INPUT-OUTPUT SECTION.
  12421. 001300 FILE-CONTROL.
  12422. 001400     SELECT VA1Z-OUT   ASSIGN TO D1
  12423. 001500          ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  12424. 001600     SELECT VA1K-IN    ASSIGN TO I1
  12425. 001700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  12426. 001800    SELECT PRINT-FILE  ASSIGN TO P1-PRINTER
  12427. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  12428. 002000 DATA DIVISION.
  12429. 002100 SUB-SCHEMA SECTION.
  12430. 002200 DB  CODVAL2 WITHIN BLMDIC.
  12431. 002300 FILE SECTION.
  12432. 002400 FD VA1Z-OUT
  12433. 002500      CODE-SET IS GBCD
  12434. 002600     LABEL RECORD IS STANDARD.
  12435. 002700 01  VA1Z-RCD  PIC X(90).
  12436. 002800 FD  VA1K-IN
  12437. 002900     CODE-SET IS GBCD
  12438. 003000     LABEL RECORDS ARE STANDARD.
  12439. 003100 01  VA1K-RCD.
  12440. 003200     03  REC-TYP-I1            PIC XXXX.
  12441. 003300     03  SDRP-I1               PIC X(8).
  12442. 003400     03  FILLER                PIC X(78).
  12443. 003500 FD  PRINT-FILE
  12444. 003600     CODE-SET IS GBCD
  12445. 003700     LABEL RECORDS ARE STANDARD
  12446. 003800     DATA RECORD IS PRINT-RCD.
  12447. 003900 01  PRINT-RCD                         PIC X(132).
  12448. 004000 WORKING-STORAGE SECTION.
  12449. 004100 77  1ST-TIME-FLG  PIC 9(01)  COMP-4  VALUE ZERO.
  12450. 004200 77  AD-ST-H  PIC X(02).
  12451. 004300 77  DUPE-1-HLD   PIC X(14)    VALUE SPACES.
  12452. 004400 77  DUPE-2-HLD   PIC X(4)    VALUE SPACES.
  12453. 004500 77  ERR-CNT   PIC 9(5)  VALUE ZERO.
  12454. 004600 77  ERROR-SW     COMP-4                PIC 9 VALUE ZERO.
  12455. 004700 77  HDR-SW1      COMP-4                PIC 9 VALUE ZERO.
  12456. 004800 77  HDR-SW2      COMP-4                PIC 9 VALUE ZERO.
  12457. 004900 77  HDR-SW3      COMP-4                PIC 9 VALUE ZERO.
  12458. 005000 77  LINE-CNT     COMP-4                PIC 99 VALUE ZERO.
  12459. 005100 77  PAGE-NO      COMP-4                PIC 9(6) VALUE ZERO.
  12460. 005200 77  PAGE-SW      COMP-4                PIC 9 VALUE 1.
  12461. 005300 77  PROCESS-SW   COMP-4                PIC 9 VALUE ZERO.
  12462. 005400 77  SS1A  PIC 9(01)  COMP-4  VALUE 1.
  12463. 005500 77  SUB          COMP-4               PIC 9 VALUE 1.
  12464. 005600 77  TOTL-SW      COMP-4               PIC 9 VALUE ZERO.
  12465. 005700 01  HOLD-AREA.
  12466. 005800     03  ALLOT-NUM-HOLD                 PIC X(4).
  12467. 005900     03  BLM-ADM-HOLD.
  12468. 006000         05  ST-HOLD                    PIC XX.
  12469. 006100         05  DT-HOLD                    PIC XX.
  12470. 006200         05  RA-HOLD                    PIC XX.
  12471. 006300         05  PLU-HOLD                   PIC XX.
  12472. 006400     03  DATE-H.
  12473. 006500         05  YEAR-H                         PIC X(02).
  12474. 006600         05  MON-H                          PIC 9(02).
  12475. 006700         05  DAY-H                          PIC X(02).
  12476. 006800     03  DE-CD-EXPLN-8827-DECE-H.
  12477. 006900         05  DE-H  PIC 9(04).
  12478. 007000         05  FILLER  PIC X(36).
  12479. 007100     03  DE-EXT-CD-NAM-8825-DEEE-H.
  12480. 007200         05  ALL-SEC  PIC X(01).
  12481. 007300         05  1-SEC  PIC X(01)  OCCURS 36 TIMES.
  12482. 007400         05  FILLER  PIC X(15).
  12483. 007500     03  DIST-H                         PIC XX.
  12484. 007600     03  EXPL-HOLD.
  12485. 007700         05  DIST-NAME                  PIC X(10).
  12486. 007800         05  FILLER                     PIC X.
  12487. 007900         05  RA-NAME                    PIC X(12).
  12488. 008000         05  FILLER                     PIC X.
  12489. 008100         05  PLU-NAME                   PIC X(15).
  12490. 008200         05  FILLER                     PIC X.
  12491. 008300     03  FUNC-HOLD.
  12492. 008400         05  STATE-NAME                 PIC X(10).
  12493. 008500         05  FILLER                     PIC X(14).
  12494. 008600     03  MAP-SRC-HOLD                   PIC X(4).
  12495. 008700     03  MER-TWP-RNG-H.
  12496. 008800         05  MER-H  PIC X(02).
  12497. 008900         05  TWP-RNG-H  PIC X(10).
  12498. 009000     03  MTR-MER-CD-HOLD                PIC XX.
  12499. 009100     03  PASTURE-NUM-HOLD               PIC XX.
  12500. 009200 01  TABLE-AREA.
  12501. 009300     03  DE-V.
  12502. 009400         05  FILLER  PIC 9(12)  VALUE 999999999999.
  12503. 009500         05  FILLER  PIC 9(12)  VALUE 999999999999.
  12504. 009600     03  DE-T  REDEFINES  DE-V  PIC 9(04)  OCCURS 6 TIMES.
  12505. 009700     03  MO-V  PIC X(36)  VALUE "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOV
  12506. 009800-                               "DEC".
  12507. 009900     03  MO-T  REDEFINES MO-V  PIC X(03)  OCCURS 12 TIMES.
  12508. 010000 COPY DBSTATUS OF TPCOBOLIB.
  12509. 010100 01  RECORD-VA1D.
  12510. 010200     03  KEY-VA1D.
  12511. 010300         05  DIC-VA1D.
  12512. 010400             07  REC-TYP                PIC X(2).
  12513. 010500             07  FMT-NUM                PIC X(1).
  12514. 010600             07  FMT-CD                 PIC X(1).
  12515. 010700     03  BLM-ADM-U-0003.
  12516. 010800         05  BLM-ADM-4.
  12517. 010900             07  BLM-ADM-3.
  12518. 011000                 09  BLM-ADM-2.
  12519. 011100                     11  AD-ST-IN          PIC XX.
  12520. 011200                     11  BLM-ADM-DIST        PIC XX.
  12521. 011300                 09  BLM-ADM-RA              PIC XX.
  12522. 011400             07  BLM-ADM-PLU                 PIC XX.
  12523. 011500         05  ALLOT-NUM                       PIC X(4).
  12524. 011600         05  PASTURE-NUM                PIC X(2).
  12525. 011700         05  DATA-DATE.
  12526. 011800             07  DATA-DATE-YY           PIC X(2).
  12527. 011900             07  DATA-DATE-MM           PIC X(2).
  12528. 012000             07  DATA-DATE-DD           PIC X(2).
  12529. 012100         05  ACTN-CD                    PIC X(1).
  12530. 012200         05  MAP-SRC-IN                    PIC X(4).
  12531. 012300         05  MTR-MER-CD-IN                 PIC X(2).
  12532. 012400         05  LIN-NUM                    PIC X(4).
  12533. 012500     03  TWP-RNG-IN.
  12534. 012600         05  MTR-TWNSHP-IN.
  12535. 012700             07  TWNSHIP-3                 PIC X(3).
  12536. 012800             07  TWNSHIP-2                 PIC XX.
  12537. 012900         05  MTR-RNG-IN.
  12538. 013000             07  RNGE-3                    PIC X(3).
  12539. 013100             07  RNGE-2                    PIC XX.
  12540. 013200     03  SEC-SECT-IN.
  12541. 013300         05  FILLER  PIC X(01).
  12542. 013400         05  SEC-C2-3-IN  PIC 9(02).
  12543. 013500     03  SWA.
  12544. 013600         05  SWA-CD                     PIC X(1).
  12545. 013700         05  SWA-NUM                    PIC X(3).
  12546. 013800     03  ALIQ-PART.
  12547. 013900         05  ALIQ-PART-QRT     OCCURS 4 TIMES.
  12548. 014000             07  ALIQ-1                 PIC X.
  12549. 014100             07  ALIQ-2                 PIC X.
  12550. 014200             07  ALIQ-3                 PIC X.
  12551. 014300             07  ALIQ-4                 PIC X.
  12552. 014400     03  ACR-DU-OWNR                    PIC X(5).
  12553. 014500     03  OWN-TYP.
  12554. 014600         05  OWN-TYP-2.
  12555. 014700             07  OWN-TYP-1             PIC X.
  12556. 014800             07  FILLER                PIC X.
  12557. 014900         05  FILLER                    PIC XX.
  12558. 015000     03  JURIS                          PIC X(4).
  12559. 015100     03  MGT-ADM                        PIC X(4).
  12560. 015200     03  LAND-TYP                       PIC X(4).
  12561. 015300     03  FILLER                         PIC X.
  12562. 015400 01  ERR-LINE.
  12563. 015500     03  FILLER  PIC X(12)  VALUE " THERE WERE ".
  12564. 015600     03  CNT-ERRS  PIC ZZ,ZZZ.
  12565. 015700     03  FILLER  PIC X(18)  VALUE " VA ERROR RECORDS ".
  12566. 015800     03  FILLER  PIC X(9)  VALUE "PRINTED. ".
  12567. 015900 01  HDR-1.
  12568. 016000     03  FILLER  PIC X(24)  VALUE "    PCN ES220EP1  AS OF ".
  12569. 016100     03  DD                    PIC X(02).
  12570. 016200     03  FILLER                PIC X VALUE SPACE.
  12571. 016300     03  MMM                   PIC X(03).
  12572. 016400     03  FILLER                PIC X VALUE SPACE.
  12573. 016500     03  YY                    PIC X(02).
  12574. 016600     03  FILLER                    PIC X(09) VALUE SPACES.
  12575. 016700     03  FILLER                    PIC X(48) VALUE
  12576. 016800         "USDI- BUR OF LAND MGT  ECOLOGICAL SITE INVENTORY".
  12577. 016900     03  FILLER                    PIC X(29) VALUE SPACES.
  12578. 017000     03  FILLER                    PIC X(7) VALUE "PAGE   ".
  12579. 017100     03  PAGE-CNT                  PIC Z(06).
  12580. 017200 01  HDR-2.
  12581. 017300     03  FILLER                   PIC X(17) VALUE SPACES.
  12582. 017400     03  FILLER                   PIC X(8) VALUE "STATE   ".
  12583. 017500     03  ST-HDR                   PIC X(15).
  12584. 017600     03  FILLER                   PIC X(16) VALUE SPACES.
  12585. 017700     03  FILLER                   PIC X(7) VALUE "DIST   ".
  12586. 017800     03  DIST-HDR                 PIC X(15).
  12587. 017900     03  FILLER                   PIC X(15) VALUE SPACES.
  12588. 018000     03  FILLER  PIC X(22)  VALUE "VA  EDIT ERROR LISTING".
  12589. 018100     03  FILLER                   PIC X(17) VALUE SPACES.
  12590. 018200 01  HDR-3.
  12591. 018300     03  FILLER                   PIC X(40) VALUE
  12592. 018400          "       REC TYP      ST      DIST      RA".
  12593. 018500     03  FILLER                   PIC X(40) VALUE
  12594. 018600          "        PLU        ALLOT      PASTURE   ".
  12595. 018700     03  FILLER                   PIC X(40) VALUE
  12596. 018800          "   DATE      ACTN      MAP SOURCE       ".
  12597. 018900     03  FILLER  PIC X(12)  VALUE SPACES.
  12598. 019000 01  HDR-4.
  12599. 019100     03  FILLER                   PIC X(9) VALUE SPACES.
  12600. 019200     03  FILLER                   PIC X(43) VALUE
  12601. 019300         "1-4       5-6       7-8     9-10      11-12".
  12602. 019400     03  FILLER                   PIC X(44)  VALUE
  12603. 019500         "       13-16        17-18     19-24       25".
  12604. 019600     03  FILLER                   PIC X(36)  VALUE
  12605. 019700         "          26-29                     ".
  12606. 019800 01  HDR-5.
  12607. 019900     03  FILLER                   PIC X(9) VALUE SPACES.
  12608. 020000     03  FILLER                   PIC X(42)  VALUE
  12609. 020100         "XXXX       XX        XX      XX         XX".
  12610. 020200     03  FILLER                   PIC X(45)  VALUE
  12611. 020300         "         XXXX         XX       XXXXXX       X".
  12612. 020400     03  FILLER                   PIC X(36) VALUE
  12613. 020500         "          XXXX                      ".
  12614. 020600 01  HDR-6.
  12615. 020700     03  FILLER                   PIC X(40) VALUE
  12616. 020800         "MERIDIAN LINE  TWNSHIP   RNGE   SECT    ".
  12617. 020900     03  FILLER                   PIC X(40) VALUE
  12618. 021000         "SWA    NE  1/4    NW  1/4    SW  1/4    ".
  12619. 021100     03  FILLER                   PIC X(40) VALUE
  12620. 021200         "SE  1/4   ACRES  SURF OWN  JURIS  ADMIN ".
  12621. 021300     03  FILLER                   PIC X(12) VALUE
  12622. 021400         " LAND TYPE  ".
  12623. 021500 01  HDR-7.
  12624. 021600     03  FILLER                   PIC X(40) VALUE
  12625. 021700         " 30-31  32-35   36-40   41-45  46-48   4".
  12626. 021800     03  FILLER                   PIC X(40) VALUE
  12627. 021900         "9-52    53-56      57-60      61-64     ".
  12628. 022000     03  FILLER                   PIC X(40) VALUE
  12629. 022100         " 65-68    69-73    74-77   78-81  82-85 ".
  12630. 022200     03  FILLER                   PIC X(12) VALUE
  12631. 022300         "   86-89    ".
  12632. 022400 01  HDR-8.
  12633. 022500     03  FILLER                   PIC X(40) VALUE
  12634. 022600         "   XX    XXXX  XXX XX  XXX XX   XXX     ".
  12635. 022700     03  FILLER                   PIC X(40) VALUE
  12636. 022800         "XXXX   X X X X    X X X X    X X X X    ".
  12637. 022900     03  FILLER                   PIC X(40) VALUE
  12638. 023000         "X X X X   XXXXX     XXXX    XXXX   XXXX ".
  12639. 023100     03  FILLER                   PIC X(12) VALUE
  12640. 023200         "    XXXX    ".
  12641. 023300 01  PRINT-1  VALUE SPACES.
  12642. 023400     03  FILLER                   PIC X(9).
  12643. 023500     03  REC-TYP-P                PIC X(4).
  12644. 023600     03  FILLER                   PIC X(7).
  12645. 023700     03  AD-ST-P               PIC XX.
  12646. 023800     03  FILLER                   PIC X(8).
  12647. 023900     03  BLM-ADM-DIST-P             PIC XX.
  12648. 024000     03  FILLER                   PIC X(6).
  12649. 024100     03  BLM-ADM-RA-P               PIC XX.
  12650. 024200     03  FILLER                   PIC X(9).
  12651. 024300     03  BLM-ADM-PLU-P              PIC XX.
  12652. 024400     03  FILLER                   PIC X(9).
  12653. 024500     03  ALLOT-NUM-P              PIC X(4).
  12654. 024600     03  FILLER                   PIC X(9).
  12655. 024700     03  PASTURE-NUM-P            PIC XX.
  12656. 024800     03  FILLER                   PIC X(7).
  12657. 024900     03  DATA-DATE-P              PIC X(6).
  12658. 025000     03  FILLER                   PIC X(7).
  12659. 025100     03  ACTN-CD-P                PIC X.
  12660. 025200     03  FILLER                   PIC X(10).
  12661. 025300     03  MAP-SOURCE-P            PIC X(4).
  12662. 025400     03  FILLER                  PIC X(13).
  12663. 025500     03  FILLER                  PIC X(9).
  12664. 025600 01  PRINT-2  VALUE SPACES.
  12665. 025700     03  FILLER                   PIC X(9).
  12666. 025800     03  RCD-ERR                  PIC X(4).
  12667. 025900     03  FILLER                   PIC X(7).
  12668. 026000     03  ST-ERR                  PIC XX.
  12669. 026100     03  FILLER                   PIC X(8).
  12670. 026200     03  DT-ERR                  PIC XX.
  12671. 026300     03  FILLER                   PIC X(6).
  12672. 026400     03  RA-ERR                  PIC XX.
  12673. 026500     03  FILLER                   PIC X(9).
  12674. 026600     03  PLU-ERR                  PIC XX.
  12675. 026700     03  FILLER                   PIC X(9).
  12676. 026800     03  ALLOT-ERR                  PIC X(4).
  12677. 026900     03  FILLER                   PIC X(9).
  12678. 027000     03  PASTURE-ERR                  PIC XX.
  12679. 027100     03  FILLER                   PIC X(31).
  12680. 027200     03  MAP-ERR                  PIC X(4).
  12681. 027300     03  FILLER                   PIC X(13).
  12682. 027400     03  MERID-ERR                  PIC XX.
  12683. 027500     03  FILLER                   PIC X(7) .
  12684. 027600 01  PRINT-3.
  12685. 027700     03  FILLER                       PIC X(3)  VALUE SPACES.
  12686. 027800     03  MERIDIAN-P              PIC XX.
  12687. 027900     03  FILLER                       PIC X(4)  VALUE SPACES.
  12688. 028000     03  LIN-NUM-P                    PIC X(4).
  12689. 028100     03  FILLER                       PIC X(2)  VALUE SPACES.
  12690. 028200     03  TWNSHIP-P                    PIC X(3).
  12691. 028300     03  FILLER                       PIC X VALUE ".".
  12692. 028400     03  TWNSHIP-P1                   PIC XX.
  12693. 028500     03  FILLER                       PIC XX  VALUE SPACES.
  12694. 028600     03  RNGE-P                       PIC XXX.
  12695. 028700     03  FILLER                       PIC X VALUE ".".
  12696. 028800     03  RNGE-P1                      PIC XX.
  12697. 028900     03  FILLER                       PIC XXX  VALUE SPACES.
  12698. 029000     03  SECT-P                       PIC XXX.
  12699. 029100     03  FILLER                       PIC X(5)  VALUE SPACES.
  12700. 029200     03  SWA-P                        PIC X(4).
  12701. 029300     03  FILLER                       PIC XX  VALUE SPACES.
  12702. 029400     03  FILLER                       PIC X VALUE ".".
  12703. 029500     03  NE-P                         PIC X.
  12704. 029600     03  FILLER                       PIC X VALUE ".".
  12705. 029700     03  NE-P1                        PIC X.
  12706. 029800     03  FILLER                       PIC X VALUE ".".
  12707. 029900     03  NE-P2                        PIC X.
  12708. 030000     03  FILLER                       PIC X VALUE ".".
  12709. 030100     03  NE-P3                        PIC X.
  12710. 030200     03  FILLER                       PIC X(04)  VALUE ".  .".
  12711. 030300     03  NW-P                         PIC X.
  12712. 030400     03  FILLER                       PIC X VALUE ".".
  12713. 030500     03  NW-P1                        PIC X.
  12714. 030600     03  FILLER                       PIC X VALUE ".".
  12715. 030700     03  NW-P2                        PIC X.
  12716. 030800     03  FILLER                       PIC X VALUE ".".
  12717. 030900     03  NW-P3                        PIC X.
  12718. 031000     03  FILLER                       PIC X(04)  VALUE ".  .".
  12719. 031100     03  SW-P                         PIC X.
  12720. 031200     03  FILLER                       PIC X VALUE ".".
  12721. 031300     03  SW-P1                        PIC X.
  12722. 031400     03  FILLER                       PIC X VALUE ".".
  12723. 031500     03  SW-P2                        PIC X.
  12724. 031600     03  FILLER                       PIC X VALUE ".".
  12725. 031700     03  SW-P3                        PIC X.
  12726. 031800     03  FILLER                       PIC X(04)  VALUE ".  .".
  12727. 031900     03  SE-P                         PIC X.
  12728. 032000     03  FILLER                       PIC X VALUE ".".
  12729. 032100     03  SE-P1                        PIC X.
  12730. 032200     03  FILLER                       PIC X VALUE ".".
  12731. 032300     03  SE-P2                        PIC X.
  12732. 032400     03  FILLER                       PIC X VALUE ".".
  12733. 032500     03  SE-P3                        PIC X.
  12734. 032600     03  FILLER                       PIC XXX VALUE ".  ".
  12735. 032700     03  ACRES-P                      PIC X(5).
  12736. 032800     03  FILLER                       PIC X(5)  VALUE SPACES.
  12737. 032900     03  SURF-OWN-P                   PIC X(4).
  12738. 033000     03  FILLER                       PIC X(4)  VALUE SPACES.
  12739. 033100     03  JURIS-P                      PIC X(4).
  12740. 033200     03  FILLER                       PIC X(3)  VALUE SPACES.
  12741. 033300     03  ADMIN-P                      PIC X(4).
  12742. 033400     03  FILLER                       PIC X(5)  VALUE SPACES.
  12743. 033500     03  LAND-TYP-P                   PIC X(4).
  12744. 033600     03  FILLER                       PIC X(4)  VALUE SPACES.
  12745. 033700 01  PRINT-4  VALUE SPACES.
  12746. 033800     03  FILLER                   PIC X(15).
  12747. 033900     03  TWNSHIP-ERR                 PIC X(6).
  12748. 034000     03  FILLER                   PIC X(2).
  12749. 034100     03  RNGE-ERR                 PIC X(6).
  12750. 034200     03  FILLER                   PIC X(3).
  12751. 034300     03  SECT-ERR                 PIC X(3).
  12752. 034400     03  FILLER                   PIC X(5).
  12753. 034500     03  SWA-ERR                 PIC X(4).
  12754. 034600     03  FILLER                   PIC XX.
  12755. 034700     03  NE-ERR                 PIC X(9).
  12756. 034800     03  FILLER                   PIC X(2).
  12757. 034900     03  NW-ERR                 PIC X(9).
  12758. 035000     03  FILLER                   PIC X(2).
  12759. 035100     03  SW-ERR                 PIC X(9).
  12760. 035200     03  FILLER                   PIC X(2).
  12761. 035300     03  SE-ERR                 PIC X(9).
  12762. 035400     03  FILLER                   PIC X(2).
  12763. 035500     03  ACRES-ERR                 PIC X(5).
  12764. 035600     03  FILLER                   PIC X(5).
  12765. 035700     03  SURF-ERR                 PIC X(4).
  12766. 035800     03  FILLER                   PIC X(4).
  12767. 035900     03  JURIS-ERR                 PIC X(4).
  12768. 036000     03  FILLER                   PIC X(3).
  12769. 036100     03  ADMIN-ERR                 PIC X(4).
  12770. 036200     03  FILLER                   PIC X(5).
  12771. 036300     03  LND-TYP-ERR                 PIC X(4).
  12772. 036400     03  FILLER                   PIC X(4).
  12773. 036500 01  INFO-LIN-1.
  12774. 036600     03  FILLER                        PIC X(24) VALUE SPACES.
  12775. 036700     03  FILLER                        PIC X(38) VALUE
  12776. 036800         "IF ERROR CORRECTION IS IN COMMON DATA ".
  12777. 036900     03  FILLER                        PIC X(46) VALUE
  12778. 037000         "(1-29), KEY ALL RECORDS WITH SAME COMMON DATA.".
  12779. 037100     03  FILLER                        PIC X(24) VALUE SPACES.
  12780. 037200 01  INFO-LIN-2.
  12781. 037300     03  FILLER                        PIC X(24) VALUE SPACES.
  12782. 037400     03  FILLER                        PIC X(42) VALUE
  12783. 037500         "IF ERROR CORRECTION IS IN FIELD POSITIONS ".
  12784. 037600     03  FILLER                        PIC X(45) VALUE
  12785. 037700         "(30-89), KEY (1-35) AND RED CORRECTED FIELDS.".
  12786. 037800     03  FILLER                        PIC X(21) VALUE SPACES.
  12787. 037900 PROCEDURE DIVISION.
  12788. 038000 START-SECTION.
  12789. 038100     OPEN INPUT  VA1K-IN,
  12790. 038200          OUTPUT PRINT-FILE, VA1Z-OUT.  READY DIC-DE.
  12791. 038300     ACCEPT DATE-H FROM DATE.  MOVE DAY-H TO DD.
  12792. 038400     MOVE MO-T (MON-H) TO MMM.  MOVE YEAR-H TO YY.
  12793. 038500 010-READ.
  12794. 038600     READ VA1K-IN AT END  GO TO 260-END.
  12795. 038700     IF SDRP-I1 = "WY047825"
  12796. 038800         MOVE "WY048835" TO SDRP-I1.
  12797. 038900     MOVE VA1K-RCD TO RECORD-VA1D.
  12798. 039000 020-HOLD.
  12799. 039100     MOVE BLM-ADM-4 TO BLM-ADM-HOLD.
  12800. 039200     MOVE ALLOT-NUM TO ALLOT-NUM-HOLD.
  12801. 039300     MOVE PASTURE-NUM TO PASTURE-NUM-HOLD.
  12802. 039400     MOVE MAP-SRC-IN TO MAP-SRC-HOLD.
  12803. 039500     MOVE MTR-MER-CD-IN TO MTR-MER-CD-HOLD.
  12804. 039600 025-EDIT-RCD-TYP.
  12805. 039700     IF DIC-VA1D = "VA1D"
  12806. 039800         GO TO 035-BLM-ST.
  12807. 039900     IF REC-TYP  =  "VA"
  12808. 040000         GO TO 030-ERROR-VA.
  12809. 040100     DISPLAY "RECORD NOT PROCESSED" VA1K-RCD.
  12810. 040200     GO TO 010-READ.
  12811. 040300 030-ERROR-VA.
  12812. 040400     MOVE 1 TO HDR-SW1.
  12813. 040500     MOVE ALL "*" TO RCD-ERR.
  12814. 040600 035-BLM-ST.
  12815. 040700     MOVE AD-ST-IN TO DE-CD-8822-DEC.
  12816. 040800     MOVE 0003 TO DE-NO-8801-DEC.
  12817. 040900     FIND ANY CODE-DEC.
  12818. 041000     MOVE DB-STATUS TO DATA-BASE-STATUS.
  12819. 041100     IF OK
  12820. 041200         GET CODE-DEC
  12821. 041300            MOVE DE-CD-NAM-8823-DEC TO FUNC-HOLD
  12822. 041400            MOVE STATE-NAME TO ST-HDR
  12823. 041500            GO TO 040-BLM-DIST.
  12824. 041600     MOVE 1 TO HDR-SW1.
  12825. 041700     MOVE "UNKNOWN" TO ST-HDR, DIST-HDR.
  12826. 041800     MOVE ALL "*" TO ST-ERR, DT-ERR, RA-ERR, PLU-ERR.
  12827. 041900     GO TO 060-EXIT-BLM.
  12828. 042000 040-BLM-DIST.
  12829. 042100     MOVE BLM-ADM-2 TO DE-CD-8822-DEC.
  12830. 042200     MOVE 0003 TO DE-NO-8801-DEC.
  12831. 042300     FIND ANY CODE-DEC.
  12832. 042400     MOVE DB-STATUS TO DATA-BASE-STATUS.
  12833. 042500     IF OK
  12834. 042600         GET CODE-DEC
  12835. 042700         GO TO 045-FIND-DT.
  12836. 042800     MOVE "UNKNOWN" TO DIST-HDR.
  12837. 042900     MOVE 1 TO HDR-SW1.
  12838. 043000     MOVE ALL "*" TO DT-ERR, RA-ERR, PLU-ERR.
  12839. 043100     GO TO 060-EXIT-BLM.
  12840. 043200 045-FIND-DT.
  12841. 043300     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  12842. 043400     MOVE DB-STATUS TO DATA-BASE-STATUS.
  12843. 043500     IF OK
  12844. 043600         GET CODE-EXPL-DECE
  12845. 043700         MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HOLD
  12846. 043800         MOVE DIST-NAME TO DIST-HDR
  12847. 043900         GO TO 050-BLM-RA.
  12848. 044000     MOVE "UNKNOWN" TO DIST-HDR.
  12849. 044100 050-BLM-RA.
  12850. 044200     MOVE BLM-ADM-3 TO DE-CD-8822-DEC.
  12851. 044300     MOVE 0003 TO DE-NO-8801-DEC.
  12852. 044400     FIND ANY CODE-DEC.
  12853. 044500     MOVE DB-STATUS TO DATA-BASE-STATUS.
  12854. 044600     IF OK
  12855. 044700         GO TO 055-BLM-PLU.
  12856. 044800     MOVE 1 TO HDR-SW1.
  12857. 044900     MOVE ALL "*" TO RA-ERR, PLU-ERR.
  12858. 045000     GO TO 060-EXIT-BLM.
  12859. 045100 055-BLM-PLU.
  12860. 045200     MOVE BLM-ADM-4 TO DE-CD-8822-DEC.
  12861. 045300     MOVE 0003 TO DE-NO-8801-DEC.
  12862. 045400     FIND ANY CODE-DEC.
  12863. 045500     MOVE DB-STATUS TO DATA-BASE-STATUS.
  12864. 045600     IF OK
  12865. 045700         GO TO 060-EXIT-BLM.
  12866. 045800     MOVE ALL "*" TO PLU-ERR.
  12867. 045900     MOVE 1 TO HDR-SW1.
  12868. 046000 060-EXIT-BLM.
  12869. 046100     EXIT.
  12870. 046200 065-EDIT-ALLOT.
  12871. 046300     IF ALLOT-NUM NUMERIC
  12872. 046400         GO TO 070-EDIT-PASTURE.
  12873. 046500     MOVE 1 TO HDR-SW1.
  12874. 046600     MOVE ALL "*" TO ALLOT-ERR.
  12875. 046700 070-EDIT-PASTURE.
  12876. 046800     IF PASTURE-NUM = SPACES
  12877. 046900         GO TO 075-MAP-SRC.
  12878. 047000     IF PASTURE-NUM = ZERO
  12879. 047100         GO TO 075-MAP-SRC.
  12880. 047200     IF PASTURE-NUM NUMERIC AND PASTURE-NUM > ZERO
  12881. 047300         GO TO 075-MAP-SRC.
  12882. 047400     MOVE 1 TO HDR-SW1.
  12883. 047500     MOVE ALL "*" TO PASTURE-ERR.
  12884. 047600 075-MAP-SRC.
  12885. 047700     MOVE 3540 TO DE-NO-8801-DEC.
  12886. 047800     MOVE MAP-SRC-IN TO DE-CD-8822-DEC.
  12887. 047900     FIND ANY CODE-DEC.  MOVE DB-STATUS TO DATA-BASE-STATUS.
  12888. 048000     IF NOT OK  MOVE 1 TO HDR-SW1,  MOVE ALL "*" TO MAP-ERR.
  12889. 048100     IF 1ST-TIME-FLG NOT ZERO  GO TO 082-CHK-AD-ST-IN.
  12890. 048200     MOVE 1 TO 1ST-TIME-FLG.  MOVE 0100 TO DE-NO-8801-DEC.
  12891. 048300     MOVE AD-ST-IN TO AD-ST-H, DE-CD-8822-DEC.
  12892. 048400     FIND ANY CODE-DEC.  MOVE DB-STATUS TO DATA-BASE-STATUS.
  12893. 048500     IF NOT OK  DISPLAY "STATE ", AD-ST-IN,
  12894. 048600         " NOT IN DE DIC - RUN ABORTED"  CALL "ABOR".
  12895. 048700     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  12896. 048800     MOVE DB-STATUS TO DATA-BASE-STATUS.
  12897. 048900     IF NOT OK  DISPLAY "NO DE FOR STATE ",
  12898. 049000         AD-ST-IN, " - RUN ABORTED"  CALL "ABOR".
  12899. 049100 080-GET-LOOP.
  12900. 049200     GET.  MOVE DE-CD-EXPLN-8827-DECE TO DE-CD-EXPLN-8827-DECE-H.
  12901. 049300     MOVE DE-H TO DE-T (SS1A).
  12902. 049400     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  12903. 049500     MOVE DB-STATUS TO DATA-BASE-STATUS.
  12904. 049600     IF NOT OK  GO TO 082-CHK-AD-ST-IN.
  12905. 049700     ADD 1 TO SS1A.  IF SS1A > 5  DISPLAY
  12906. 049800         "MORE THAN 5 DE'S FOR STATE ", AD-ST-IN,
  12907. 049900         " - RUN ABORTED"  CALL "ABOR".  GO TO 080-GET-LOOP.
  12908. 050000 082-CHK-AD-ST-IN.
  12909. 050100     IF AD-ST-IN NOT = AD-ST-H  DISPLAY "STATE IN ", AD-ST-IN,
  12910. 050200         " NOT EQUAL TO STATE HOLD ", AD-ST-H,
  12911. 050300         " - RUN ABORTED"  CALL "ABOR".
  12912. 050400     MOVE MTR-MER-CD-IN TO MER-H.  MOVE TWP-RNG-IN TO TWP-RNG-H.
  12913. 050500     MOVE MER-TWP-RNG-H TO DE-EXT-CD-8824-DEE.  MOVE 1 TO SS1A.
  12914. 050600 084-DE-LOOP.
  12915. 050700     MOVE DE-T (SS1A) TO DE-NO-8801-DEE.
  12916. 050800     IF DE-NO-8801-DEE = 9999  GO TO 090-MER-TWP-RNG-ERR.
  12917. 050900     FIND ANY EXT-CODE-DEE.  MOVE DB-STATUS TO DATA-BASE-STATUS.
  12918. 051000     IF NOT OK  GO TO 088-CHK-SS1A.
  12919. 051100     IF SEC-SECT-IN NOT NUMERIC
  12920. 051200         OR SEC-SECT-IN < "001" OR > "036"  GO TO 092-SEC-ERR.
  12921. 051300     FIND NEXT EXT-CODE-EXPL-DEEE WITHIN DEE-DEEE.
  12922. 051400     MOVE DB-STATUS TO DATA-BASE-STATUS.
  12923. 051500     IF NOT OK  DISPLAY "NO SECTIONS FOR MER, TWP, RNG ",
  12924. 051600         MER-TWP-RNG-H, " - RUN ABORTED"  CALL "ABOR".
  12925. 051700 086-GET-LOOP.
  12926. 051800     GET.
  12927. 051900     MOVE DE-EXT-CD-NAM-8825-DEEE TO DE-EXT-CD-NAM-8825-DEEE-H.
  12928. 052000     IF ALL-SEC = "X" OR 1-SEC (SEC-C2-3-IN) = "X"
  12929. 052100         GO TO 100-SWA.
  12930. 052200     FIND NEXT EXT-CODE-EXPL-DEEE WITHIN DEE-DEEE.
  12931. 052300     MOVE DB-STATUS TO DATA-BASE-STATUS.
  12932. 052400     IF NOT OK  GO TO 092-SEC-ERR.  GO TO 086-GET-LOOP.
  12933. 052500 088-CHK-SS1A.
  12934. 052600     IF SS1A < 6  ADD 1 TO SS1A  GO TO 084-DE-LOOP.
  12935. 052700 090-MER-TWP-RNG-ERR.
  12936. 052800     MOVE ALL "*" TO MERID-ERR, TWNSHIP-ERR, RNGE-ERR.
  12937. 052900     MOVE 1 TO HDR-SW2.
  12938. 053000 092-SEC-ERR.
  12939. 053100     MOVE ALL "*" TO SECT-ERR.
  12940. 053200     MOVE 1 TO HDR-SW2.
  12941. 053300 100-SWA.
  12942. 053400     IF SWA-CD NOT ALPHABETIC OR SWA-CD = SPACE
  12943. 053500         OR SWA-NUM NOT NUMERIC
  12944. 053600             MOVE 1 TO HDR-SW2  MOVE ALL "*" TO SWA-ERR.
  12945. 053700 105-ALIQ-1.
  12946. 053800     IF ALIQ-1 (SUB) NOT = SPACES AND "X"
  12947. 053900         PERFORM 125-ALIQ-ERR.
  12948. 054000     ADD 1 TO SUB.
  12949. 054100     IF SUB = 5
  12950. 054200         MOVE 1 TO SUB
  12951. 054300         GO TO 110-ALIQ-2.
  12952. 054400     GO TO 105-ALIQ-1.
  12953. 054500 110-ALIQ-2.
  12954. 054600     IF ALIQ-2 (SUB) NOT = SPACES AND "X"
  12955. 054700         PERFORM 125-ALIQ-ERR.
  12956. 054800     ADD 1 TO SUB.
  12957. 054900     IF SUB = 5
  12958. 055000         MOVE 1 TO SUB
  12959. 055100         GO TO 115-ALIQ-3.
  12960. 055200     GO TO 110-ALIQ-2.
  12961. 055300 115-ALIQ-3.
  12962. 055400     IF ALIQ-3 (SUB) NOT = SPACES AND "X"
  12963. 055500         PERFORM 125-ALIQ-ERR.
  12964. 055600     ADD 1 TO SUB.
  12965. 055700     IF SUB = 5
  12966. 055800         MOVE 1 TO SUB
  12967. 055900         GO TO 120-ALIQ-4.
  12968. 056000     GO TO 115-ALIQ-3.
  12969. 056100 120-ALIQ-4.
  12970. 056200     IF ALIQ-4 (SUB) NOT = SPACES AND "X"
  12971. 056300         PERFORM 125-ALIQ-ERR.
  12972. 056400     ADD 1 TO SUB.
  12973. 056500     IF SUB = 5
  12974. 056600         MOVE 1 TO SUB
  12975. 056700         GO TO 130-EXIT-ALIQ.
  12976. 056800     GO TO 120-ALIQ-4.
  12977. 056900 125-ALIQ-ERR.
  12978. 057000     IF SUB = 1
  12979. 057100         MOVE ALL "*" TO NE-ERR.
  12980. 057200     IF SUB = 2
  12981. 057300         MOVE ALL "*" TO NW-ERR.
  12982. 057400     IF SUB = 3
  12983. 057500         MOVE ALL "*" TO SW-ERR.
  12984. 057600     IF SUB = 4
  12985. 057700         MOVE ALL "*" TO SE-ERR.
  12986. 057800     MOVE 1 TO HDR-SW2.
  12987. 057900 130-EXIT-ALIQ.
  12988. 058000     EXIT.
  12989. 058100 140-ACRES.
  12990. 058200     IF ACR-DU-OWNR NUMERIC AND ACR-DU-OWNR > ZERO
  12991. 058300          GO TO 145-OWNERSHIP.
  12992. 058400     MOVE 1 TO HDR-SW2.
  12993. 058500     MOVE ALL "*" TO ACRES-ERR.
  12994. 058600 145-OWNERSHIP.
  12995. 058700     IF OWN-TYP = "TOTL"
  12996. 058800         PERFORM 400-ZERO-OUT
  12997. 058900         MOVE 1 TO TOTL-SW
  12998. 059000         GO TO 164-TOTL-SW.
  12999. 059100     IF OWN-TYP-2  = "NC" OR "NP" OR
  13000. 059200          "NQ" OR "NS" OR "NT"
  13001. 059300         GO TO 146-BLANK.
  13002. 059400     IF OWN-TYP-2 = "FA" OR "FP"
  13003. 059500         GO TO 150-JURIS.
  13004. 059600     IF OWN-TYP-1 = "P" OR "S"
  13005. 059700         GO TO 146-BLANK.
  13006. 059800     MOVE 1 TO HDR-SW2.
  13007. 059900     MOVE ALL "*" TO SURF-ERR.
  13008. 060000     GO TO 150-JURIS.
  13009. 060100 146-BLANK.
  13010. 060200     IF JURIS NOT = TO SPACES
  13011. 060300         MOVE 1 TO HDR-SW2
  13012. 060400         MOVE ALL "*" TO JURIS-ERR SURF-ERR.
  13013. 060500     IF MGT-ADM NOT = TO SPACES
  13014. 060600         MOVE 1 TO HDR-SW2
  13015. 060700         MOVE ALL "*" TO ADMIN-ERR SURF-ERR.
  13016. 060800     IF LAND-TYP NOT = TO SPACES
  13017. 060900         MOVE 1 TO HDR-SW2
  13018. 061000         MOVE ALL "*" TO LND-TYP-ERR SURF-ERR.
  13019. 061100     GO TO 165-EXIT-EDIT.
  13020. 061200 150-JURIS.
  13021. 061300     MOVE JURIS TO DE-CD-8822-DEC.
  13022. 061400     MOVE 2576 TO DE-NO-8801-DEC.
  13023. 061500     FIND ANY CODE-DEC.
  13024. 061600     MOVE DB-STATUS TO DATA-BASE-STATUS.
  13025. 061700     IF OK
  13026. 061800         GO TO 155-ADMIN.
  13027. 061900     MOVE 1 TO HDR-SW2.
  13028. 062000     MOVE ALL "*" TO JURIS-ERR.
  13029. 062100 155-ADMIN.
  13030. 062200     MOVE MGT-ADM TO DE-CD-8822-DEC.
  13031. 062300     MOVE 2576 TO DE-NO-8801-DEC.
  13032. 062400     FIND ANY CODE-DEC.
  13033. 062500     MOVE DB-STATUS TO DATA-BASE-STATUS.
  13034. 062600     IF OK
  13035. 062700         GO TO 160-TYP-LAND.
  13036. 062800     MOVE 1 TO HDR-SW2.
  13037. 062900     MOVE ALL "*" TO ADMIN-ERR.
  13038. 063000 160-TYP-LAND.
  13039. 063100     MOVE LAND-TYP TO DE-CD-8822-DEC.
  13040. 063200     MOVE 3801 TO DE-NO-8801-DEC.
  13041. 063300     FIND ANY CODE-DEC.
  13042. 063400     MOVE DB-STATUS TO DATA-BASE-STATUS.
  13043. 063500     IF OK
  13044. 063600         GO TO 165-EXIT-EDIT.
  13045. 063700     MOVE 1 TO HDR-SW2.
  13046. 063800     MOVE ALL "*" TO LND-TYP-ERR.
  13047. 063900 164-TOTL-SW.
  13048. 064000     IF TOTL-SW = 1
  13049. 064100         MOVE ZERO TO TOTL-SW
  13050. 064200         GO TO 010-READ.
  13051. 064300 165-EXIT-EDIT.
  13052. 064400     EXIT.
  13053. 064500 168-SWITCH-CHECK.
  13054. 064600     IF HDR-SW1 = ZERO
  13055. 064700         GO TO 180-HDR-SW2.
  13056. 064800     IF PAGE-SW = 1
  13057. 064900         PERFORM 410-HDR-ST-DIST
  13058. 065000         MOVE ZERO TO PAGE-SW.
  13059. 065100     PERFORM 420-HDRS-CNTL.
  13060. 065200 170-WRITE-CONTROL.
  13061. 065300     PERFORM 430-MOVE-CTL-DATA.
  13062. 065400     MOVE PRINT-2 TO PRINT-RCD.
  13063. 065500     WRITE PRINT-RCD BEFORE 2.
  13064. 065600     ADD 2 TO LINE-CNT.
  13065. 065700     MOVE 1 TO ERROR-SW.
  13066. 065800 175-WRITE-LIN-DATA.
  13067. 065900     PERFORM 440-HDRS-LIN-DATA.
  13068. 066000     PERFORM 450-LIN-DATA.
  13069. 066100     IF HDR-SW2 = ZERO
  13070. 066200         MOVE SPACES TO PRINT-RCD
  13071. 066300         ELSE
  13072. 066400         MOVE PRINT-4 TO PRINT-RCD
  13073. 066500          MOVE 1 TO ERROR-SW.
  13074. 066600     WRITE PRINT-RCD BEFORE 2.
  13075. 066700     ADD 2 TO LINE-CNT.
  13076. 066800 176-DUMMY.
  13077. 066900     GO TO 185-NEW-RCD.
  13078. 067000 180-HDR-SW2.
  13079. 067100     IF HDR-SW2 = ZERO
  13080. 067200         GO TO 185-NEW-RCD.
  13081. 067300     IF PAGE-SW = ZERO
  13082. 067400         PERFORM 175-WRITE-LIN-DATA
  13083. 067500         GO TO 185-NEW-RCD.
  13084. 067600     PERFORM 410-HDR-ST-DIST THRU 430-MOVE-CTL-DATA.
  13085. 067700     MOVE SPACES TO PRINT-RCD.
  13086. 067800     WRITE PRINT-RCD BEFORE 2.
  13087. 067900     ADD 2 TO LINE-CNT.
  13088. 068000     PERFORM 440-HDRS-LIN-DATA THRU 450-LIN-DATA.
  13089. 068100     MOVE PRINT-4 TO PRINT-RCD.
  13090. 068200     WRITE PRINT-RCD BEFORE 2.
  13091. 068300     ADD 2 TO LINE-CNT.
  13092. 068400     MOVE ZERO TO PAGE-SW.
  13093. 068500 185-NEW-RCD.
  13094. 068600     IF PASTURE-NUM = SPACES
  13095. 068700         MOVE ZERO TO PASTURE-NUM.
  13096. 068800     MOVE RECORD-VA1D TO VA1Z-RCD.
  13097. 068900     WRITE VA1Z-RCD.
  13098. 069000 195-READ-VA1K.
  13099. 069100     READ VA1K-IN AT END  GO TO 260-END.
  13100. 069200     IF SDRP-I1 = "WY047825"
  13101. 069300         MOVE "WY048835" TO SDRP-I1.
  13102. 069400     MOVE VA1K-RCD TO RECORD-VA1D.
  13103. 069500     IF DIC-VA1D = "VA1D"
  13104. 069600         GO TO 200-BLM-ST.
  13105. 069700     IF REC-TYP = "VA"
  13106. 069800         PERFORM 030-ERROR-VA
  13107. 069900         GO TO 200-BLM-ST.
  13108. 070000     DISPLAY "RECORD NOT PROCESSED".
  13109. 070100     DISPLAY VA1K-RCD.
  13110. 070200     GO TO 195-READ-VA1K.
  13111. 070300 200-BLM-ST.
  13112. 070400     IF AD-ST-IN = ST-HOLD
  13113. 070500         GO TO 210-BLM-DIST.
  13114. 070600     PERFORM 205-NEW-PAGE.
  13115. 070700     GO TO 035-BLM-ST.
  13116. 070800 205-NEW-PAGE.
  13117. 070900     MOVE ZERO TO PAGE-NO.
  13118. 071000     PERFORM 400-ZERO-OUT.
  13119. 071100     PERFORM 020-HOLD.
  13120. 071200 210-BLM-DIST.
  13121. 071300     IF BLM-ADM-DIST = DT-HOLD
  13122. 071400         GO TO 215-BLM-RA.
  13123. 071500     PERFORM 205-NEW-PAGE.
  13124. 071600     MOVE SPACES TO PRINT-2, PRINT-4.
  13125. 071700     GO TO 035-BLM-ST.
  13126. 071800 215-BLM-RA.
  13127. 071900     IF BLM-ADM-RA = RA-HOLD
  13128. 072000         GO TO 220-BLM-PLU.
  13129. 072100     MOVE 1 TO PAGE-SW.
  13130. 072200     PERFORM 400-ZERO-OUT.
  13131. 072300     PERFORM 020-HOLD.
  13132. 072400     GO TO 035-BLM-ST.
  13133. 072500 220-BLM-PLU.
  13134. 072600     IF BLM-ADM-PLU = PLU-HOLD
  13135. 072700         GO TO 225-EDIT-ALLOT.
  13136. 072800     MOVE 1 TO PAGE-SW.
  13137. 072900     PERFORM 400-ZERO-OUT.
  13138. 073000     PERFORM 020-HOLD.
  13139. 073100     GO TO 035-BLM-ST.
  13140. 073200 225-EDIT-ALLOT.
  13141. 073300     IF ALLOT-NUM = ALLOT-NUM-HOLD
  13142. 073400         GO TO 230-PASTURE.
  13143. 073500     MOVE 1 TO PAGE-SW.
  13144. 073600     PERFORM 400-ZERO-OUT.
  13145. 073700     PERFORM 020-HOLD.
  13146. 073800     GO TO 065-EDIT-ALLOT.
  13147. 073900 230-PASTURE.
  13148. 074000     IF PASTURE-NUM = PASTURE-NUM-HOLD
  13149. 074100         GO TO 235-MAP.
  13150. 074200     MOVE 1 TO PAGE-SW.
  13151. 074300     PERFORM 400-ZERO-OUT.
  13152. 074400     PERFORM 020-HOLD.
  13153. 074500     GO TO 070-EDIT-PASTURE.
  13154. 074600 235-MAP.
  13155. 074700     IF MAP-SRC-IN = MAP-SRC-HOLD
  13156. 074800          GO TO 240-MERIDIAN.
  13157. 074900     MOVE 1 TO PAGE-SW.
  13158. 075000     PERFORM 400-ZERO-OUT.
  13159. 075100     PERFORM 020-HOLD.
  13160. 075200     GO TO 075-MAP-SRC.
  13161. 075300 240-MERIDIAN.
  13162. 075400     IF MTR-MER-CD-IN = MTR-MER-CD-HOLD
  13163. 075500         GO TO 245-CONTROL-EQUAL.
  13164. 075600     MOVE 1 TO PAGE-SW.
  13165. 075700     PERFORM 400-ZERO-OUT.
  13166. 075800     PERFORM 020-HOLD.
  13167. 075900     GO TO 082-CHK-AD-ST-IN.
  13168. 076000 245-CONTROL-EQUAL.
  13169. 076100     MOVE SPACES TO PRINT-4.
  13170. 076200     MOVE ZERO TO HDR-SW2.
  13171. 076300     PERFORM 082-CHK-AD-ST-IN THRU 165-EXIT-EDIT.
  13172. 076400     IF OWN-TYP = "TOTL"
  13173. 076500         PERFORM 400-ZERO-OUT
  13174. 076600         GO TO 195-READ-VA1K.
  13175. 076700     IF HDR-SW1 NOT = TO ZERO
  13176. 076800          GO TO 246-PAGE.
  13177. 076900     IF HDR-SW2 = ZERO
  13178. 077000         GO TO 185-NEW-RCD.
  13179. 077100 246-PAGE.
  13180. 077200     IF PAGE-SW = ZERO
  13181. 077300         GO TO 250-CONTINUE.
  13182. 077400     MOVE ZERO TO PAGE-SW.
  13183. 077500     PERFORM 410-HDR-ST-DIST THRU 430-MOVE-CTL-DATA.
  13184. 077600     IF HDR-SW1 = ZERO
  13185. 077700         MOVE SPACES TO PRINT-RCD
  13186. 077800         ELSE
  13187. 077900         MOVE PRINT-2 TO PRINT-RCD
  13188. 078000         MOVE 1 TO ERROR-SW.
  13189. 078100     WRITE PRINT-RCD BEFORE 2.
  13190. 078200     ADD 2 TO LINE-CNT.
  13191. 078300     PERFORM 440-HDRS-LIN-DATA.
  13192. 078400 250-CONTINUE.
  13193. 078500     PERFORM 450-LIN-DATA.
  13194. 078600     IF HDR-SW2 = ZERO
  13195. 078700          MOVE SPACES TO PRINT-RCD
  13196. 078800          ELSE
  13197. 078900          MOVE PRINT-4 TO PRINT-RCD
  13198. 079000          MOVE 1 TO ERROR-SW.
  13199. 079100     MOVE 0 TO HDR-SW2.
  13200. 079200     WRITE PRINT-RCD BEFORE 2.
  13201. 079300     ADD 2 TO LINE-CNT.
  13202. 079400     IF LINE-CNT > 54
  13203. 079500         MOVE 1 TO PAGE-SW.
  13204. 079600     GO TO 185-NEW-RCD.
  13205. 079700 260-END.
  13206. 079800     IF ERROR-SW = 1
  13207. 079900         MOVE ERR-CNT TO CNT-ERRS, DISPLAY ERR-LINE
  13208. 080000     ELSE DISPLAY " NO ERRORS DETECTED".
  13209. 080100     CLOSE PRINT-FILE, VA1K-IN, VA1Z-OUT.
  13210. 080200     FINISH DIC-DE, STOP RUN.
  13211. 080300 400-ZERO-OUT.
  13212. 080400     MOVE ZERO TO HDR-SW1, HDR-SW2.
  13213. 080500     MOVE SPACES TO PRINT-2, PRINT-4.
  13214. 080600 410-HDR-ST-DIST.
  13215. 080700     PERFORM 460-LINE-CNT.
  13216. 080800     MOVE HDR-1 TO PRINT-RCD.
  13217. 080900     WRITE PRINT-RCD BEFORE 2.
  13218. 081000     MOVE HDR-2 TO PRINT-RCD.
  13219. 081100     WRITE PRINT-RCD BEFORE 2.
  13220. 081200     MOVE INFO-LIN-1 TO PRINT-RCD.
  13221. 081300     WRITE PRINT-RCD BEFORE 1.
  13222. 081400     MOVE INFO-LIN-2 TO PRINT-RCD.
  13223. 081500     WRITE PRINT-RCD BEFORE 2.
  13224. 081600     ADD 7 TO LINE-CNT.
  13225. 081700 420-HDRS-CNTL.
  13226. 081800     MOVE HDR-3 TO PRINT-RCD.
  13227. 081900     WRITE PRINT-RCD BEFORE 1.
  13228. 082000     MOVE HDR-4 TO PRINT-RCD.
  13229. 082100     WRITE PRINT-RCD BEFORE 1.
  13230. 082200     MOVE HDR-5 TO PRINT-RCD.
  13231. 082300     WRITE PRINT-RCD BEFORE 2.
  13232. 082400     ADD 4 TO LINE-CNT.
  13233. 082500 430-MOVE-CTL-DATA.
  13234. 082600     MOVE DIC-VA1D TO REC-TYP-P.
  13235. 082700     MOVE AD-ST-IN TO AD-ST-P.
  13236. 082800     MOVE BLM-ADM-DIST TO BLM-ADM-DIST-P.
  13237. 082900     MOVE BLM-ADM-RA TO BLM-ADM-RA-P.
  13238. 083000     MOVE BLM-ADM-PLU TO BLM-ADM-PLU-P.
  13239. 083100     MOVE DATA-DATE TO DATA-DATE-P.
  13240. 083200     MOVE ALLOT-NUM TO ALLOT-NUM-P.
  13241. 083300     MOVE PASTURE-NUM TO PASTURE-NUM-P.
  13242. 083400     MOVE ACTN-CD TO ACTN-CD-P.
  13243. 083500     MOVE MAP-SRC-IN TO MAP-SOURCE-P.
  13244. 083600     MOVE MTR-MER-CD-IN TO MERIDIAN-P.
  13245. 083700     MOVE PRINT-1 TO PRINT-RCD.
  13246. 083800     WRITE PRINT-RCD BEFORE 1.
  13247. 083900     ADD 1 TO LINE-CNT.
  13248. 084000 440-HDRS-LIN-DATA.
  13249. 084100     MOVE HDR-6 TO PRINT-RCD.
  13250. 084200     WRITE PRINT-RCD BEFORE 1.
  13251. 084300     MOVE HDR-7 TO PRINT-RCD.
  13252. 084400     WRITE PRINT-RCD BEFORE 1.
  13253. 084500     MOVE HDR-8 TO PRINT-RCD.
  13254. 084600     WRITE PRINT-RCD BEFORE 2.
  13255. 084700     ADD 4 TO LINE-CNT.
  13256. 084800 450-LIN-DATA.
  13257. 084900     MOVE LIN-NUM TO LIN-NUM-P.
  13258. 085000     MOVE TWNSHIP-3 TO TWNSHIP-P.
  13259. 085100     MOVE TWNSHIP-2 TO TWNSHIP-P1.
  13260. 085200     MOVE RNGE-3 TO RNGE-P.
  13261. 085300     MOVE RNGE-2 TO RNGE-P1.
  13262. 085400     MOVE SEC-SECT-IN TO SECT-P.
  13263. 085500     MOVE SWA TO SWA-P.
  13264. 085600     MOVE ALIQ-1 (1) TO NE-P.
  13265. 085700     MOVE ALIQ-2 (1) TO NE-P1.
  13266. 085800     MOVE ALIQ-3 (1) TO NE-P2.
  13267. 085900     MOVE ALIQ-4 (1) TO NE-P3.
  13268. 086000     MOVE ALIQ-1 (2) TO NW-P.
  13269. 086100     MOVE ALIQ-2 (2) TO NW-P1.
  13270. 086200     MOVE ALIQ-3 (2) TO NW-P2.
  13271. 086300     MOVE ALIQ-4 (2) TO NW-P3.
  13272. 086400     MOVE ALIQ-1 (3) TO SW-P.
  13273. 086500     MOVE ALIQ-2 (3) TO SW-P1.
  13274. 086600     MOVE ALIQ-3 (3) TO SW-P2.
  13275. 086700     MOVE ALIQ-4 (3) TO SW-P3.
  13276. 086800     MOVE ALIQ-1 (4) TO SE-P.
  13277. 086900     MOVE ALIQ-2 (4) TO SE-P1.
  13278. 087000     MOVE ALIQ-3 (4) TO SE-P2.
  13279. 087100     MOVE ALIQ-4 (4) TO SE-P3.
  13280. 087200     MOVE ACR-DU-OWNR TO ACRES-P.
  13281. 087300     MOVE OWN-TYP TO SURF-OWN-P.
  13282. 087400     MOVE JURIS TO JURIS-P.
  13283. 087500     MOVE MGT-ADM TO ADMIN-P.
  13284. 087600     MOVE LAND-TYP TO LAND-TYP-P.
  13285. 087700     MOVE PRINT-3 TO PRINT-RCD.
  13286. 087800     ADD 1 TO ERR-CNT.
  13287. 087900     WRITE PRINT-RCD BEFORE 1.
  13288. 088000     ADD 1 TO LINE-CNT.
  13289. 088100 460-LINE-CNT.
  13290. 088200     MOVE SPACES TO PRINT-RCD.
  13291. 088300     WRITE PRINT-RCD BEFORE PAGE.
  13292. 088400     MOVE ZERO TO LINE-CNT.
  13293. 088500     MOVE 0 TO PAGE-SW.
  13294. 088600     ADD 1 TO PAGE-NO.
  13295. 088700     MOVE PAGE-NO TO PAGE-CNT.
  13296. 000000*-----------------------------------------------------------------
  13297. 000100 IDENTIFICATION DIVISION.
  13298. 000200 PROGRAM-ID. ES230M.
  13299. 000300*        VA SUMMARY
  13300. 000400*
  13301. 000500 AUTHOR. CHUCK SLIZEWSKI.
  13302. 000600 DATE-WRITTEN.   01/10/79.
  13303. 000700 DATE-COMPILED.
  13304. 000800 ENVIRONMENT DIVISION.
  13305. 000900 CONFIGURATION SECTION.
  13306. 001000 SOURCE-COMPUTER. LEVEL-66-ASCII.
  13307. 001100 OBJECT-COMPUTER. LEVEL-66-ASCII.
  13308. 001200 INPUT-OUTPUT SECTION.
  13309. 001300 FILE-CONTROL.
  13310. 001400     SELECT FIL-D1     ASSIGN TO D1
  13311. 001500         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  13312. 001600     SELECT FIL-I1     ASSIGN TO I1
  13313. 001700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  13314. 001800     SELECT FIL-W1     ASSIGN TO W1
  13315. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  13316. 002000 DATA DIVISION.
  13317. 002100 FILE SECTION.
  13318. 002200 FD  FIL-D1
  13319. 002300     LABEL RECORDS ARE STANDARD
  13320. 002400     CODE-SET IS GBCD
  13321. 002500     DATA RECORD IS REC-D1.
  13322. 002600 01  REC-D1.
  13323. 002700     03  FILLER  PIC XXXX.
  13324. 002800     03  STATE-THRU-PAST-D1  PIC X(14).
  13325. 002900     03  FILLER  PIC X(11).
  13326. 003000     03  MERID-D1  PIC XX.
  13327. 003100     03  FILLER  PIC XXXX.
  13328. 003200     03  TN-RG-SEC-D1  PIC X(13).
  13329. 003300     03  SWA-D1  PIC XXXX.
  13330. 003400     03  FILLER  PIC X(16).
  13331. 003500     03  ACRES-D1  PIC 9(5).
  13332. 003600     03  OWNER-D1  PIC X(16).
  13333. 003700     03  FILLER  PIC X.
  13334. 003800 FD  FIL-I1
  13335. 003900     LABEL RECORDS ARE STANDARD
  13336. 004000     CODE-SET IS GBCD
  13337. 004100     DATA RECORD IS REC-I1.
  13338. 004200 01  REC-I1  PIC X(90).
  13339. 004300 SD  FIL-W1
  13340. 004400     DATA RECORD IS REC-W1.
  13341. 004500 01  REC-W1.
  13342. 004600     03  FILLER  PIC XXXX.
  13343. 004700     03  STATE-THRU-PAST-W1  PIC X(14).
  13344. 004800     03  FILLER  PIC X(11).
  13345. 004900     03  MERID-W1  PIC XX.
  13346. 005000     03  FILLER  PIC XXXX.
  13347. 005100     03  TN-RG-SEC-W1  PIC X(13).
  13348. 005200     03  SWA-W1  PIC XXXX.
  13349. 005300     03  FILLER  PIC X(16).
  13350. 005400     03  ACRES-W1  PIC 9(5).
  13351. 005500     03  OWNER-W1  PIC X(16).
  13352. 005600     03  FILLER  PIC X.
  13353. 005700 WORKING-STORAGE SECTION.
  13354. 005800 77  AD-CNTR  PIC 9(5)  COMP-4  VALUE ZERO.
  13355. 005900 77  IN-CNTR  PIC 9(5)  COMP-4  VALUE ZERO.
  13356. 006000 77  OT-CNTR  PIC 9(5)  COMP-4  VALUE 1.
  13357. 006100 PROCEDURE DIVISION.
  13358. 006200 SS SECTION.
  13359. 006300 SSP.
  13360. 006400     SORT FIL-W1 ON ASCENDING KEY STATE-THRU-PAST-W1,
  13361. 006500                                  SWA-W1,
  13362. 006600                                  MERID-W1,
  13363. 006700                                  TN-RG-SEC-W1,
  13364. 006800                                  OWNER-W1,
  13365. 006900         INPUT  PROCEDURE IS IN-PROC,
  13366. 007000         OUTPUT PROCEDURE IS OT-PROC.
  13367. 007100 IN-PROC SECTION.
  13368. 007200 IPP.
  13369. 007300     OPEN INPUT  FIL-I1.
  13370. 007400 0100-READ.
  13371. 007500     READ FIL-I1  AT END  GO TO 0200-CLOS.
  13372. 007600     MOVE REC-I1 TO REC-W1.  RELEASE REC-W1.
  13373. 007700     ADD 1 TO IN-CNTR.  GO TO 0100-READ.
  13374. 007800 0200-CLOS.
  13375. 007900     CLOSE FIL-I1.
  13376. 008000 OT-PROC SECTION.
  13377. 008100 OPP.
  13378. 008200     OPEN OUTPUT FIL-D1.
  13379. 008300     RETURN FIL-W1  AT END
  13380. 008400         DISPLAY "NO RECORDS ON SORT FILE"  CALL "ABOR".
  13381. 008500     MOVE REC-W1 TO REC-D1.
  13382. 008600 0300-READ.
  13383. 008700     RETURN FIL-W1  AT END  WRITE REC-D1
  13384. 008800         DISPLAY "RECORDS IN    = " IN-CNTR
  13385. 008900         DISPLAY "RECORDS ADDED = " AD-CNTR
  13386. 009000         DISPLAY "RECORDS OUT   = " OT-CNTR
  13387. 009100         CLOSE FIL-D1  STOP RUN.
  13388. 009200     IF STATE-THRU-PAST-D1 = STATE-THRU-PAST-W1
  13389. 009300         AND MERID-D1 = MERID-W1
  13390. 009400         AND TN-RG-SEC-D1 = TN-RG-SEC-W1
  13391. 009500         AND SWA-D1 = SWA-W1
  13392. 009600         AND OWNER-D1 = OWNER-W1
  13393. 009700         ADD ACRES-W1 TO ACRES-D1
  13394. 009800         ADD 1 TO AD-CNTR  GO TO 0300-READ.
  13395. 009900     WRITE REC-D1.  ADD 1 TO OT-CNTR.
  13396. 010000     MOVE REC-W1 TO REC-D1.  GO TO 0300-READ.
  13397. 000000*-----------------------------------------------------------------
  13398. 000100 IDENTIFICATION DIVISION.
  13399. 000200 PROGRAM-ID. ES305M.
  13400. 000300*        CONVERTS NEW FORMAT VB RECORDS TO OLD FORMAT VB (D) RECOR
  13401. 000400*
  13402. 000500 AUTHOR. GEORGIA BOSSE.
  13403. 000600 INSTALLATION.         BLM.
  13404. 000700 DATE-WRITTEN.         DECEMBER 1982.
  13405. 000800*REMARKS.     VB CONVERSION-D
  13406. 000900*        THE INPUT FILES ARE THE KEY ENTERED VB AND VC RECORDS.
  13407. 001000*        VB = BLM FORM 4412-30 (APRIL 1982)
  13408. 001100*        VC = BLM FORM 4412-37 (APRIL 1982)
  13409. 001200*        THE OUTPUT IS FORMATTED LIKE THE KEY ENTERED VB1D RECORDS
  13410. 001300*        VB1D = BLM FORM 4412-30 (JUNE 79)
  13411. 001400*        THE PROGRAM SORTS THE VC FILE BY STRATUM INTO A TEMPORARY
  13412. 001500*        AND THEN SORTS THE VB FILE BY STRATUM.  THE FILES ARE MAT
  13413. 001600*        ON STRATUM AND ALL VB RECORDS FOR WHICH THERE IS A MATCHI
  13414. 001700*        VC RECORD ARE REFORMATTED INTO THE VB1D FILE.  IF NO MATC
  13415. 001800*        VC RECORD IS FOUND AN ERROR MESSAGE IS PRINTED AND THE PR
  13416. 001900*        READS THE NEXT VB RECORD.  IF THE PROGRAM REACHES THE END
  13417. 002000*        OF THE VC FILE WITHOUT MATCHING THE VB STRATUM OR FINDING
  13418. 002100*        HIGHER STRATUM THE PROGRAM PRINTS A MESSAGE AND TERMINATE
  13419. 002200 ENVIRONMENT DIVISION.
  13420. 002300 CONFIGURATION SECTION.
  13421. 002400 SOURCE-COMPUTER.      LEVEL-66-ASCII.
  13422. 002500 OBJECT-COMPUTER.      LEVEL-66-ASCII SEQUENCE IS EBCDIC.
  13423. 002600 INPUT-OUTPUT SECTION.
  13424. 002700 FILE-CONTROL.
  13425. 002800     SELECT  VB1D-FILE  ASSIGN D1
  13426. 002900             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  13427. 003000     SELECT  VC-FILE ASSIGN I1
  13428. 003100             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  13429. 003200     SELECT  VB-FILE ASSIGN I2
  13430. 003300             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  13431. 003400     SELECT VC-SORT-OUT-FILE ASSIGN DZ.
  13432. 003500     SELECT VC-SORT-FILE ASSIGN ASORT.
  13433. 003600     SELECT VB-SORT-FILE ASSIGN BSORT.
  13434. 003700 DATA DIVISION.
  13435. 003800 FILE SECTION.
  13436. 003900 FD  VC-FILE
  13437. 004000     CODE-SET IS GBCD
  13438. 004100     LABEL RECORDS ARE STANDARD
  13439. 004200     DATA RECORD IS VC-REC.
  13440. 004300 01  VC-REC.
  13441. 004400     03  PG-NUM-I1               PIC 9999.
  13442. 004500     03  INV-CD-I1               PIC XXXX.
  13443. 004600     03  REC-TYP-I1              PIC XXX.
  13444. 004700     03  LINE-NUM-I1             PIC XX.
  13445. 004800     03  ACT-I1                  PIC X.
  13446. 004900     03  RS-NUM-I1               PIC X(11).
  13447. 005000     03  STRAT-I1                PIC X(4).
  13448. 005100     03  COND-CL-I1              PIC X.
  13449. 005200     03  COND-CL-FIL             PIC XXX.
  13450. 005300     03  VEG-SUB-TYP-I1          PIC X(4).
  13451. 005400     03  DOMINANT-PLNT-I1        PIC X(21).
  13452. 005500     03  FILLER                  PIC X(26).
  13453. 005600 FD  VB-FILE
  13454. 005700     CODE-SET IS GBCD
  13455. 005800     LABEL RECORDS ARE STANDARD
  13456. 005900     DATA RECORD IS VB-REC.
  13457. 006000 01  VB-REC.
  13458. 006100     03  PG-I2                   PIC X(4).
  13459. 006200     03  INV-CD-I2               PIC X(4).
  13460. 006300     03  REC-TYP-I2              PIC XXX.
  13461. 006400     03  RA-I2                   PIC XX.
  13462. 006500     03  PU-I2                   PIC XX.
  13463. 006600     03  ALLOT-I2                PIC X(4).
  13464. 006700     03  PASTR-I2                PIC XX.
  13465. 006800     03  LINE-NUM-I2             PIC XX.
  13466. 006900     03  ACT-I2                  PIC X.
  13467. 007000     03  SWA-I2                  PIC X(4).
  13468. 007100     03  TRN-I2                  PIC XX.
  13469. 007200     03  PCT-SWA-I2              PIC XXX.
  13470. 007300     03  STRAT-I2                PIC X(4).
  13471. 007400     03  CLMTC-ADJ-FCTR-I2       PIC X(5).
  13472. 007500     03  ELEV-I2                 PIC X(5).
  13473. 007600     03  PCT-SLP-I2              PIC XXX.
  13474. 007700     03  SLP-ASPT-I2             PIC XX.
  13475. 007800     03  LND-FRM-I2              PIC XXX.
  13476. 007900     03  SOIL-PHS-I2             PIC X(6).
  13477. 008000     03  FILLER                  PIC X(23).
  13478. 008100 FD  VB1D-FILE
  13479. 008200     CODE-SET IS GBCD
  13480. 008300     LABEL RECORDS ARE STANDARD
  13481. 008400     DATA RECORD IS VB1D-REC.
  13482. 008500 01  VB1D-REC.
  13483. 008600     03  REC-TYPE-D1             PIC X(4).
  13484. 008700     03  STATE-DIST-D1           PIC X(4).
  13485. 008800     03  RA-D1                   PIC XX.
  13486. 008900     03  PU-D1                   PIC XX.
  13487. 009000     03  CLMTC-ADJ-FCTR-D1       PIC X(5).
  13488. 009100     03  DATE-D1                 PIC X(6).
  13489. 009200     03  ACT-D1                  PIC X.
  13490. 009300     03  LINE-NUM-D1             PIC X(4).
  13491. 009400     03  SWA-D1                  PIC X(4).
  13492. 009500     03  TRN-D1                  PIC XX.
  13493. 009600     03  PCT-SWA-D1              PIC XXX.
  13494. 009700     03  RS-NUM-D1               PIC X(11).
  13495. 009800     03  STRAT-D1                PIC X(4).
  13496. 009900     03  ALLOT-D1                PIC X(4).
  13497. 010000     03  PASTR-D1                PIC XX.
  13498. 010100     03  VEG-SUB-TYP-D1          PIC X(4).
  13499. 010200     03  COND-CL-D1              PIC X.
  13500. 010300     03  PCT-SLP-D1              PIC XXX.
  13501. 010400     03  SLP-ASPT-D1             PIC XX.
  13502. 010500     03  LND-FRM-D1              PIC XXX.
  13503. 010600     03  SOIL-PHS-D1             PIC X(6).
  13504. 010700     03  FILLER                  PIC X(19).
  13505. 010800 FD  VC-SORT-OUT-FILE
  13506. 010900     LABEL RECORDS ARE STANDARD
  13507. 011000     DATA RECORD IS VC-SORT-OUT.
  13508. 011100 01  VC-SORT-OUT.
  13509. 011200     03  PG-NUM-SVC               PIC 9999.
  13510. 011300     03  INV-CD-SVC               PIC XXXX.
  13511. 011400     03  REC-TYP-SVC              PIC XXX.
  13512. 011500     03  LINE-NUM-SVC             PIC XX.
  13513. 011600     03  ACT-SVC                  PIC X.
  13514. 011700     03  RS-NUM-SVC               PIC X(11).
  13515. 011800     03  STRAT-SVC                PIC X(4).
  13516. 011900     03  COND-CL-SVC              PIC X(4).
  13517. 012000     03  VEG-SUB-TYP-SVC          PIC X(4).
  13518. 012100     03  DOMINANT-PLNT-SVC        PIC X(21).
  13519. 012200     03  FILLER                  PIC X(26).
  13520. 012300 SD  VC-SORT-FILE
  13521. 012400     DATA RECORD IS VC-SORT-REC.
  13522. 012500 01  VC-SORT-REC.
  13523. 012600     03  FILLER       PIC X(25).
  13524. 012700     03  STRAT-IS-KEY  PIC X(4).
  13525. 012800     03  FILLER        PIC X(55).
  13526. 012900 SD  VB-SORT-FILE
  13527. 013000     DATA RECORD IS VB-SORT-REC.
  13528. 013100 01  VB-SORT-REC.
  13529. 013200     03  PG-SVB                  PIC X(4).
  13530. 013300     03  INV-SVB                 PIC X(4).
  13531. 013400     03  REC-TYP-SVB             PIC XXX.
  13532. 013500     03  RA-SVB                  PIC XX.
  13533. 013600     03  PU-SVB                  PIC XX.
  13534. 013700     03  ALLOT-SVB               PIC X(4).
  13535. 013800     03  PASTR-SVB               PIC XX.
  13536. 013900     03  LINE-NUM-SVB            PIC XX.
  13537. 014000     03  ACT-SVB                 PIC X.
  13538. 014100     03  SWA-SVB                 PIC X(4).
  13539. 014200     03  TRN-SVB                 PIC XX.
  13540. 014300     03  PCT-SWA-SVB             PIC XXX.
  13541. 014400     03  STRAT-SVB               PIC X(4).
  13542. 014500     03  CLMTC-ADJ-FCTR-SVB      PIC X(5).
  13543. 014600     03  ELEV-SVB                PIC X(5).
  13544. 014700     03  PCT-SLP-SVB             PIC XXX.
  13545. 014800     03  SLP-ASPT-SVB            PIC XX.
  13546. 014900     03  LND-FRM-SVB             PIC XXX.
  13547. 015000     03  SOIL-PHS-SVB            PIC X(6).
  13548. 015100     03  FILLER                  PIC X(23).
  13549. 015200 WORKING-STORAGE SECTION.
  13550. 015300 77  ERR-CNT                     PIC 9  VALUE ZERO.
  13551. 015400 77  VB1D-CNT                    PIC 99999  VALUE ZERO.
  13552. 015500 77  TODAYS-DATE                 PIC X(06).
  13553. 015600 01  INV-ST-DIST.
  13554. 015700     03  INVENTORY               PIC XXXX.
  13555. 015800     03  STATE-DIST              PIC X(4).
  13556. 015900 PROCEDURE DIVISION.
  13557. 016000 A100-HOUSE SECTION.
  13558. 016100 A100-HOUSEKEEPING.
  13559. 016200     ACCEPT TODAYS-DATE FROM DATE.
  13560. 016300     ACCEPT INV-ST-DIST.
  13561. 016400 B200-SORT-VC SECTION.
  13562. 016500 B210-SORT-VC.
  13563. 016600     SORT VC-SORT-FILE ON ASCENDING KEY
  13564. 016700         STRAT-IS-KEY
  13565. 016800         INPUT PROCEDURE IS C300-INPUT-VC
  13566. 016900            GIVING VC-SORT-OUT-FILE.
  13567. 017000 B250-SORT-VB SECTION.
  13568. 017100 B260-SORT-VB.
  13569. 017200     CLOSE VC-FILE.
  13570. 017300     SORT VB-SORT-FILE ON ASCENDING KEY
  13571. 017400         STRAT-SVB
  13572. 017500         INPUT PROCEDURE IS D400-INPUT-VB
  13573. 017600             OUTPUT PROCEDURE IS E600-OUTPUT.
  13574. 017700 B290-STOP.
  13575. 017800     CLOSE VC-SORT-OUT-FILE.
  13576. 017900     DISPLAY " OUTPUT RECORDS=" VB1D-CNT
  13577. 018000     STOP RUN.
  13578. 018100 C300-INPUT-VC SECTION.
  13579. 018200 C310-OPEN.
  13580. 018300     MOVE ZERO TO ERR-CNT.
  13581. 018400     OPEN INPUT VC-FILE.
  13582. 018500 C320-READ-VC-FILE.
  13583. 018600     READ VC-FILE AT END
  13584. 018700         GO TO C300-EXIT.
  13585. 018800     IF REC-TYP-I1 NOT = "VC "
  13586. 018900         ADD 1 TO ERR-CNT
  13587. 019000         DISPLAY " INVALID REC-TYP "  VC-REC
  13588. 019100         IF ERR-CNT = 5
  13589. 019200             DISPLAY " CHECK COMPLETE FILE - ABORT - "
  13590. 019300             STOP RUN
  13591. 019400             ELSE
  13592. 019500             GO TO C320-READ-VC-FILE.
  13593. 019600     IF INVENTORY NOT = INV-CD-I1
  13594. 019700         DISPLAY " INVENTORY UNMATCHED WITH VC-REC"
  13595. 019800         DISPLAY " INVENTORY REQUESTED= " INVENTORY
  13596. 019900         DISPLAY "THIS FILE IS   " INV-CD-I1
  13597. 020000         STOP RUN.
  13598. 020100     MOVE VC-REC TO VC-SORT-REC.
  13599. 020200     RELEASE VC-SORT-REC.
  13600. 020300     GO TO C320-READ-VC-FILE.
  13601. 020400 C300-EXIT.
  13602. 020500     EXIT.
  13603. 020600 D400-INPUT-VB SECTION.
  13604. 020700 D410-OPEN.
  13605. 020800     MOVE ZERO TO ERR-CNT.
  13606. 020900     OPEN INPUT VB-FILE.
  13607. 021000 D420-READ-VB-FILE.
  13608. 021100     READ VB-FILE AT END
  13609. 021200         GO TO D400-EXIT.
  13610. 021300     IF REC-TYP-I2 NOT = "VB "
  13611. 021400         ADD 1 TO ERR-CNT
  13612. 021500         DISPLAY " INVBLID REC-TYP "  VC-REC
  13613. 021600         IF ERR-CNT = 5
  13614. 021700             DISPLAY " CHECK COMPLETE FILE - ABORT - "
  13615. 021800             STOP RUN
  13616. 021900             ELSE
  13617. 022000             GO TO D420-READ-VB-FILE.
  13618. 022100     IF INVENTORY NOT = INV-CD-I2
  13619. 022200         DISPLAY " INVENTORY UNMATCHED WITH VB-REC"
  13620. 022300         DISPLAY " INVENTORY REQUESTED= " INVENTORY
  13621. 022400         DISPLAY "THIS FILE IS   " INV-CD-I2
  13622. 022500         STOP RUN.
  13623. 022600     MOVE VB-REC TO VB-SORT-REC.
  13624. 022700     RELEASE VB-SORT-REC.
  13625. 022800     GO TO D420-READ-VB-FILE.
  13626. 022900 D400-EXIT.
  13627. 023000     EXIT.
  13628. 023100 E600-OUTPUT SECTION.
  13629. 023200 E610-OPEN.
  13630. 023300     OPEN INPUT VC-SORT-OUT-FILE.
  13631. 023400     MOVE SPACES TO VB1D-REC.
  13632. 023500     OPEN OUTPUT VB1D-FILE.
  13633. 023600     CLOSE VB-FILE.
  13634. 023700     READ VC-SORT-OUT-FILE AT END
  13635. 023800         DISPLAY "VB SORT FILE ERROR"
  13636. 023900         STOP RUN.
  13637. 024000 E620-RETURN.
  13638. 024100     RETURN VB-SORT-FILE AT END
  13639. 024200         GO TO E600-EXIT.
  13640. 024300     IF STRAT-SVB > STRAT-SVC
  13641. 024400         PERFORM E680-FIND-MATCH.
  13642. 024500     IF STRAT-SVB < STRAT-SVC
  13643. 024600          DISPLAY "STRATUM #" STRAT-SVB
  13644. 024700      " ON THE VB FILE HAS NO MATCHING STRATUM ON THE VC FILE"
  13645. 024800         GO TO E620-RETURN.
  13646. 024900* MOVE STANDARD FILE DATA
  13647. 025000     MOVE STATE-DIST TO STATE-DIST-D1.
  13648. 025100     MOVE "A" TO ACT-D1.
  13649. 025200     MOVE TODAYS-DATE TO DATE-D1.
  13650. 025300     MOVE "VB1D" TO REC-TYPE-D1.
  13651. 025400     MOVE ZEROES TO LINE-NUM-D1.
  13652. 025500* MOVE DATA FROM VB-RECORD
  13653. 025600     MOVE SWA-SVB TO SWA-D1.
  13654. 025700     MOVE RA-SVB TO RA-D1.
  13655. 025800     MOVE PU-SVB TO PU-D1.
  13656. 025900     MOVE ALLOT-SVB TO ALLOT-D1.
  13657. 026000     MOVE PASTR-SVB TO PASTR-D1.
  13658. 026100     MOVE TRN-SVB TO TRN-D1.
  13659. 026200     MOVE PCT-SWA-SVB TO PCT-SWA-D1.
  13660. 026300     MOVE STRAT-SVB TO STRAT-D1.
  13661. 026400     MOVE CLMTC-ADJ-FCTR-SVB TO CLMTC-ADJ-FCTR-D1.
  13662. 026500     MOVE PCT-SLP-SVB TO PCT-SLP-D1.
  13663. 026600     MOVE SLP-ASPT-SVB TO SLP-ASPT-D1.
  13664. 026700     MOVE LND-FRM-SVB TO LND-FRM-D1.
  13665. 026800     MOVE SOIL-PHS-SVB TO SOIL-PHS-D1.
  13666. 026900* MOVE DATA FROM VC-RECORD
  13667. 027000     MOVE RS-NUM-SVC TO RS-NUM-D1.
  13668. 027100     MOVE COND-CL-SVC TO COND-CL-D1.
  13669. 027200     MOVE VEG-SUB-TYP-SVC TO VEG-SUB-TYP-D1.
  13670. 027300     WRITE VB1D-REC.
  13671. 027400     MOVE SPACES TO VB1D-REC.
  13672. 027500     ADD 1 TO VB1D-CNT.
  13673. 027600     GO TO E620-RETURN.
  13674. 027700 E680-FIND-MATCH.
  13675. 027800     READ VC-SORT-OUT-FILE AT END
  13676. 027900          DISPLAY "CURRENT VB FILE IS AT STRATUM #" STRAT-SVB
  13677. 028000          DISPLAY "THERE ARE NO MORE STRATA ON THE VC FILE"
  13678. 028100          GO TO E600-EXIT.
  13679. 028200     IF STRAT-SVB > STRAT-SVC
  13680. 028300          GO TO E680-FIND-MATCH.
  13681. 028400 E600-EXIT.
  13682. 028500     EXIT.
  13683. 028600 DUMMY SECTION.
  13684. 028700 D900-END.
  13685. 000000*-----------------------------------------------------------------
  13686. 000100 IDENTIFICATION DIVISION.
  13687. 000200 PROGRAM-ID. ES310U.
  13688. 000300*        INITIAL EDIT/UPDATE OF STRATIFICATION (VB) AND
  13689. 000400*            ECOLOGICAL SITE (VR) FORMATS.
  13690. 000500*
  13691. 000600 AUTHOR. CARLANDER.
  13692. 000700 INSTALLATION.         BLM.
  13693. 000800 DATE-WRITTEN.         AUGUST 1979.
  13694. 000900*REMARKS.              ERROR UPDATE OF STRATUM AND
  13695. 001000*                      ECOLOGICAL SITE DESCRIPTION.
  13696. 001100*
  13697. 001200 ENVIRONMENT DIVISION.
  13698. 001300 CONFIGURATION SECTION.
  13699. 001400 SOURCE-COMPUTER.      LEVEL-66-ASCII.
  13700. 001500 OBJECT-COMPUTER.      LEVEL-66-ASCII SEQUENCE IS EBCDIC.
  13701. 001600 INPUT-OUTPUT SECTION.
  13702. 001700 FILE-CONTROL.
  13703. 001800     SELECT  NEW-FILE  ASSIGN D1
  13704. 001900             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  13705. 002000     SELECT  TRAN-FILE ASSIGN I1
  13706. 002100             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  13707. 002200     SELECT  OPTIONAL PREV-FILE ASSIGN I2
  13708. 002300             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  13709. 002400     SELECT  SORT-FILE ASSIGN I1 I2 I3.
  13710. 002500 DATA DIVISION.
  13711. 002600 FILE SECTION.
  13712. 002700 FD  PREV-FILE
  13713. 002800     CODE-SET IS GBCD
  13714. 002900     LABEL RECORDS ARE STANDARD
  13715. 003000     DATA RECORDS ARE VB1X-RCD VR1X-RCD VR2X-RCD VR3X-RCD.
  13716. 003100 01  VB1X-RCD.
  13717. 003200     02  REC-TYP-VB1X           PIC X(02).
  13718. 003300     02  FMT-NUM-VB1X           PIC X(01).
  13719. 003400     02  FMT-CD-VB1X            PIC X(01).
  13720. 003500     02  SDRP-VB1X.
  13721. 003600         03 BLM-ADM-U-ST-VB1X   PIC X(02).
  13722. 003700         03 BLM-ADM-U-DIST-VB1X PIC X(02).
  13723. 003800         03 BLM-ADM-U-RA-VB1X   PIC X(02).
  13724. 003900         03 BLM-ADM-U-PLU-VB1X  PIC X(02).
  13725. 004000     02  CLMTC-ADJ-FCTR-VB1X    PIC X(05).
  13726. 004100     02  DATA-DATE-VB1X         PIC X(06).
  13727. 004200     02  ACTN-CD-VB1X           PIC X(01).
  13728. 004300     02  LIN-NUM-VB1X           PIC X(04).
  13729. 004400     02  SWA-VB1X               PIC X(04).
  13730. 004500     02  TRN-NUM-VB1X           PIC X(02).
  13731. 004600     02  SWA-PCT-VB1X           PIC X(03).
  13732. 004700     02  RNG-SITE-ID-VB1X       PIC X(11).
  13733. 004800     02  STRATUM-NUM-VB1X       PIC X(04).
  13734. 004900     02  ALLOT-NUM-VB1X         PIC X(04).
  13735. 005000     02  PASTURE-NUM-VB1X       PIC X(02).
  13736. 005100     02  VEG-SUB-TYP-VB1X       PIC X(04).
  13737. 005200     02  RNG-ECOL-COND-CLS-VB1X PIC X(01).
  13738. 005300     02  PCT-SPL-VB1X           PIC X(03).
  13739. 005400     02  ASPT-VB1X              PIC X(02).
  13740. 005500     02  L-FORM-VB1X            PIC X(03).
  13741. 005600     02  SOIL-PHAS-VB1X         PIC X(05).
  13742. 005700     02      FIL                 PIC X(20).
  13743. 005800 01  VR1X-RCD.
  13744. 005900     02  VR1X-CTL.
  13745. 006000         03  REC-TYP-VR1X        PIC X(02).
  13746. 006100         03  FMT-NUM-CD-VR1X.
  13747. 006200             05  FMT-NUM-VR1X        PIC X(01).
  13748. 006300             05  FMT-CD-VR1X         PIC X(01).
  13749. 006400         03  BLM-ADM-U-ST-VR1X   PIC X(02).
  13750. 006500     02  FIL                     PIC X(06).
  13751. 006600     02  DATA-DATE-VR1X          PIC X(06).
  13752. 006700     02  ACTN-CD-VR1X            PIC X(01).
  13753. 006800     02  RNG-SITE-ID-VR1X        PIC X(11).
  13754. 006900     02  LIN-NUM-VR1X            PIC X(04).
  13755. 007000     02  RNG-SITE-NAM-VR1X       PIC X(08).
  13756. 007100     02  PRECIP-ZONE-VR1X        PIC X(04).
  13757. 007200     02  SSF-VAL-AVG-VR1X        PIC X(03).
  13758. 007300     02  POTN-PPA-RS-GRP-VR1X.
  13759. 007400         03  POTN-PPA-RS-VR1X OCCURS 3 TIMES
  13760. 007500                                 PIC X(06).
  13761. 007600     02  FIL                     PIC X(29).
  13762. 007700 01  VR2X-RCD.
  13763. 007800     02  VR2X-CTL.
  13764. 007900         03  REC-TYP-VR2X        PIC X(02).
  13765. 008000         03  FMT-NUM-CD-VR2X.
  13766. 008100             05  FMT-NUM-VR2X        PIC X(01).
  13767. 008200             05  FMT-CD-VR2X         PIC X(01).
  13768. 008300         03  BLM-ADM-U-ST-VR2X   PIC X(02).
  13769. 008400     02  FIL                     PIC X(06).
  13770. 008500     02  DATA-DATE-VR2X          PIC X(06).
  13771. 008600     02  ACTN-CD-VR2X            PIC X(01).
  13772. 008700     02  RNG-SITE-ID-VR2X        PIC X(11).
  13773. 008800     02  LIN-NUM-VR2X            PIC X(04).
  13774. 008900     02  PLANT-POTN-VR2X OCCURS 4 TIMES.
  13775. 009000         03  PLANT-CD-VR2X       PIC X(07).
  13776. 009100         03  POTN-PPA-RS-PCT-VR2X PIC X(03).
  13777. 009200     02  PLANT-TYP-VR2X          PIC X(01) OCCURS 4 TIMES.
  13778. 009300     02  FIL                     PIC X(18).
  13779. 009400 01  VR3X-RCD.
  13780. 009500     02  VR3X-CTL.
  13781. 009600         03  REC-TYP-VR3X        PIC X(02).
  13782. 009700         03  FMT-NUM-VR3X        PIC X(01).
  13783. 009800         03  FMT-CD-VR3X         PIC X(01).
  13784. 009900         03  BLM-ADM-U-ST-VR3X   PIC X(02).
  13785. 010000     02  FIL                     PIC X(06).
  13786. 010100     02  DATA-DATE-VR3X          PIC X(06).
  13787. 010200     02  ACTN-CD-VR3X            PIC X(01).
  13788. 010300     02  RNG-SITE-ID-VR3X        PIC X(11).
  13789. 010400     02  LIN-NUM-VR3X            PIC X(04).
  13790. 010500     02  SP-SN-VR3X OCCURS 2 TIMES.
  13791. 010600         03  SOIL-PHAS-VR3X      PIC X(05).
  13792. 010700         03  SOIL-NAM-VR3X       PIC X(24).
  13793. 010800     02  FIL                     PIC X(04).
  13794. 010900 FD  TRAN-FILE
  13795. 011000     CODE-SET IS GBCD
  13796. 011100     LABEL RECORDS ARE STANDARD
  13797. 011200     DATA RECORDS ARE REC-VB-TF REC-VR-TF.
  13798. 011300 01 REC-VB-TF.
  13799. 011400     03  REC-TYP-VB-TF   PIC XX.
  13800. 011500     03  FMT-NUM-CD-VB-TF   PIC XX.
  13801. 011600     03  ST-VB-TF    PIC XX.
  13802. 011700     03  DS-VB-TF    PIC XX.
  13803. 011800     03  RA-VB-TF    PIC XX.
  13804. 011900     03  PU-VB-TF    PIC XX.
  13805. 012000     03  CAF-VB-TF   PIC X(5).
  13806. 012100     03  FILLER      PIC X(6).
  13807. 012200     03  ACTN-VB-TF    PIC X.
  13808. 012300     03  LINE-VB-TF  PIC XXXX.
  13809. 012400     03  SWAT-VB-TF  PIC X(6).
  13810. 012500     03  SWA-PCT-VB-TF   PIC XXX.
  13811. 012600     03  RNG-SITE-VB-TF  PIC X(11).
  13812. 012700     03  STRATUM-VB-TF   PIC XXXX.
  13813. 012800     03  ALOT-VB-TF      PIC XXXX.
  13814. 012900     03  PAST-VB-TF      PIC XX.
  13815. 013000     03  FILLER          PIC X(38).
  13816. 013100 01 REC-VR-TF.
  13817. 013200     03  FILLER       PIC X(18).
  13818. 013300     03  ACTN-VR-TF   PIC X.
  13819. 013400     03  RNG-SITE-VR-TF   PIC X(11).
  13820. 013500     03  LINE-VR-TF       PIC XXXX.
  13821. 013600     03  FILLER           PIC X(62).
  13822. 013700 FD  NEW-FILE
  13823. 013800     CODE-SET IS GBCD
  13824. 013900     LABEL RECORDS ARE STANDARD
  13825. 014000     DATA RECORDS ARE VB1Z-RCD VR1Z-RCD VR2Z-RCD VR3Z-RCD.
  13826. 014100 01  VB1Z-RCD.
  13827. 014200     02  REC-TYP-VB1Z           PIC X(02).
  13828. 014300     02  FMT-NUM-CD-VB1Z.
  13829. 014400         03  FMT-NUM-VB1Z           PIC X(01).
  13830. 014500         03  FMT-CD-VB1Z            PIC X(01).
  13831. 014600     02  SDRP-VB1Z.
  13832. 014700      03 BLM-ADM-U-ST-VB1Z      PIC X(02).
  13833. 014800      03 BLM-ADM-U-DIST-VB1Z    PIC X(02).
  13834. 014900      03 BLM-ADM-U-RA-VB1Z      PIC X(02).
  13835. 015000      03 BLM-ADM-U-PLU-VB1Z     PIC X(02).
  13836. 015100     02  CLMTC-ADJ-FCTR-VB1Z    PIC X(05).
  13837. 015200     02  DATA-DATE-VB1Z         PIC X(06).
  13838. 015300     02  ACTN-CD-VB1Z           PIC X(01).
  13839. 015400     02  LIN-NUM-VB1Z           PIC X(04).
  13840. 015500     02  SWA-VB1Z               PIC X(04).
  13841. 015600     02  TRN-NUM-VB1Z           PIC X(02).
  13842. 015700     02  SWA-PCT-VB1Z           PIC X(03).
  13843. 015800     02  RNG-SITE-ID-VB1Z       PIC X(11).
  13844. 015900     02  STRATUM-NUM-VB1Z       PIC X(04).
  13845. 016000     02  ALLOT-NUM-VB1Z         PIC X(04).
  13846. 016100     02  PASTURE-NUM-VB1Z       PIC X(02).
  13847. 016200     02  VEG-SUB-TYP-VB1Z       PIC X(04).
  13848. 016300     02  RNG-ECOL-COND-CLS-VB1Z PIC X(01).
  13849. 016400     02  PCT-SPL-VB1Z           PIC X(03).
  13850. 016500     02  ASPT-VB1Z              PIC X(02).
  13851. 016600     02  L-FORM-VB1Z            PIC X(03).
  13852. 016700     02  SOIL-PHAS-VB1Z         PIC X(05).
  13853. 016800     02      FIL                 PIC X(20).
  13854. 016900 01  VR1Z-RCD.
  13855. 017000     02  VR1Z-CTL.
  13856. 017100         03  REC-TYP-VR1Z        PIC X(02).
  13857. 017200         03  FMT-NUM-VR1Z        PIC X(01).
  13858. 017300         03  FMT-CD-VR1Z         PIC X(01).
  13859. 017400         03  BLM-ADM-U-ST-VR1Z   PIC X(02).
  13860. 017500     02  FIL                     PIC X(06).
  13861. 017600     02  DATA-DATE-VR1Z          PIC X(06).
  13862. 017700     02  ACTN-CD-VR1Z            PIC X(01).
  13863. 017800     02  RNG-SITE-ID-VR1Z        PIC X(11).
  13864. 017900     02  LIN-NUM-VR1Z            PIC X(04).
  13865. 018000     02  RNG-SITE-NAM-VR1Z       PIC X(08).
  13866. 018100     02  PRECIP-ZONE-VR1Z        PIC X(04).
  13867. 018200     02  SSF-VAL-AVG-VR1Z        PIC X(03).
  13868. 018300     02  POTN-PPA-RS-GRP-VR1Z.
  13869. 018400         03  POTN-PPA-RS-VR1Z OCCURS 3 TIMES
  13870. 018500                                 PIC X(06).
  13871. 018600     02  FIL                     PIC X(29).
  13872. 018700 01  VR2Z-RCD.
  13873. 018800     02  VR2Z-CTL.
  13874. 018900         03  REC-TYP-VR2Z        PIC X(02).
  13875. 019000         03  FMT-NUM-VR2Z        PIC X(01).
  13876. 019100         03  FMT-CD-VR2Z         PIC X(01).
  13877. 019200         03  BLM-ADM-U-ST-VR2Z   PIC X(02).
  13878. 019300     02  FIL                     PIC X(06).
  13879. 019400     02  DATA-DATE-VR2Z          PIC X(06).
  13880. 019500     02  ACTN-CD-VR2Z            PIC X(01).
  13881. 019600     02  RNG-SITE-ID-VR2Z        PIC X(11).
  13882. 019700     02  LIN-NUM-VR2Z            PIC X(04).
  13883. 019800     02  PLANT-POTN-VR2Z OCCURS 4 TIMES.
  13884. 019900         03  PLANT-CD-VR2Z       PIC X(07).
  13885. 020000         03  POTN-PPA-RS-PCT-VR2Z PIC X(03).
  13886. 020100     02  PLANT-TYP-VR2Z          PIC X(01) OCCURS 4 TIMES.
  13887. 020200     02  FIL                     PIC X(18).
  13888. 020300 01  VR3Z-RCD.
  13889. 020400     02  VR3Z-CTL.
  13890. 020500         03  REC-TYP-VR3Z        PIC X(02).
  13891. 020600         03  FMT-NUM-VR3Z        PIC X(01).
  13892. 020700         03  FMT-CD-VR3Z         PIC X(01).
  13893. 020800         03  BLM-ADM-U-ST-VR3Z   PIC X(02).
  13894. 020900     02  FIL                     PIC X(06).
  13895. 021000     02  DATA-DATE-VR3Z          PIC X(06).
  13896. 021100     02  ACTN-CD-VR3Z            PIC X(01).
  13897. 021200     02  RNG-SITE-ID-VR3Z        PIC X(11).
  13898. 021300     02  LIN-NUM-VR3Z            PIC X(04).
  13899. 021400     02  SP-SN-VR3Z OCCURS 2 TIMES.
  13900. 021500         03  SOIL-PHAS-VR3Z      PIC X(05).
  13901. 021600         03  SOIL-NAM-VR3Z       PIC X(24).
  13902. 021700     02  FIL                     PIC X(04).
  13903. 021800*
  13904. 021900 SD  SORT-FILE
  13905. 022000     DATA RECORD IS SORT-REC.
  13906. 022100 01  SORT-REC.
  13907. 022200     02  SR-KEY.
  13908. 022300         03  SORT-KEY-1.
  13909. 022400             05  REC-TYP-SR      PIC XX.
  13910. 022500             05  ST-SR          PIC XX.
  13911. 022600         03  GROUP-VB-SR.
  13912. 022700             05  SORT-KEY-2.
  13913. 022800                 07  LINE-CNTL-VB-SR.
  13914. 022900                     09  DS-VB-SR          PIC XX.
  13915. 023000                     09  RA-VB-SR         PIC XX.
  13916. 023100                     09  PU-VB-SR        PIC XX.
  13917. 023200                 07  LINE-VB-SR        PIC X(04).
  13918. 023300             05  SORT-FIELDS-VB-SR.
  13919. 023400                 07  ALOT-VB-SR        PIC XXXX.
  13920. 023500                 07  PAST-VB-SR        PIC XX.
  13921. 023600                 07  SWAT-VB-SR        PIC X(6).
  13922. 023700                 07  STRAT-VB-SR        PIC XXXX.
  13923. 023800                 07  CAF-VB-SR        PIC X(5).
  13924. 023900         03  GROUP-VR-SR REDEFINES GROUP-VB-SR.
  13925. 024000             05  SORT-KEY-3.
  13926. 024100                 07  LINE-CNTL-VR-SR.
  13927. 024200                     09  RNG-SITE-VR-SR   PIC X(11).
  13928. 024300                     09  FMT-NUM-CD-VR-SR   PIC XX.
  13929. 024400                 07  LINE-VR-SR        PIC XXXX.
  13930. 024500             05  FILLER           PIC X(14).
  13931. 024600     02  SR-DATA.
  13932. 024700         03  SR-DATA-1.
  13933. 024800             05  SR-RT    PIC XXXX.
  13934. 024900             05  FILLER   PIC X(19).
  13935. 025000         03  SR-DATA-2               PIC X(05).
  13936. 025100         03  SR-DATA-3               PIC X(68).
  13937. 025200 WORKING-STORAGE SECTION.
  13938. 025300 77 END-OF-TRAN        PIC X(01) VALUE " ".
  13939. 025400 77 END-OF-PREV        PIC X(01) VALUE " ".
  13940. 025500 77 LAST-LIN-NUM       PIC 9(04) VALUE 0000.
  13941. 025600 77 DATE-SW            PIC X(01).
  13942. 025700 77 DATE-MV-SW         PIC X(01).
  13943. 025800 77 TODAYS-DATE        PIC X(06).
  13944. 025900 01  PARAMETER.
  13945. 026000     03  RELINE-CHK    PIC XXX.
  13946. 026100     03  FILLER        PIC X(77).
  13947. 026200 01  CTRS.
  13948. 026300     02  VB1-CTR     PIC 99999 VALUE 0.
  13949. 026400     02  VR1-CTR     PIC 99999 VALUE 0.
  13950. 026500     02  VR2-CTR     PIC 99999 VALUE 0.
  13951. 026600     02  VR3-CTR     PIC 99999 VALUE 0.
  13952. 026700 01 DATE-WORK.
  13953. 026800     02  DW-YY         PIC X(02).
  13954. 026900     02  DW-MM         PIC X(02).
  13955. 027000     02  DW-DD         PIC X(02).
  13956. 027100 01  MOVED-DATE.
  13957. 027200     02  MD-DD         PIC XX.
  13958. 027300     02  MD-YY         PIC XX.
  13959. 027400     02  MD-MM         PIC XX.
  13960. 027500 01  TRAN-CTL.
  13961. 027600     03  TRAN-CTL-1.
  13962. 027700         05  REC-TYP-TC     PIC XX VALUE SPACES.
  13963. 027800         05  FILLER     PIC XX.
  13964. 027900     03  GRP-VB-TC.
  13965. 028000         05  TRAN-CTL-2     PIC X(10).
  13966. 028100         05  FILLER-TC      PIC X(7).
  13967. 028200     03  GRP-VR-TC REDEFINES GRP-VB-TC.
  13968. 028300         05  TRAN-CTL-3     PIC X(17).
  13969. 028400 01  PREV-CTL.
  13970. 028500     03  PREV-CNTL-1.
  13971. 028600         05  REC-TYP-PC      PIC XX.
  13972. 028700         05  ST-PC          PIC XX.
  13973. 028800     03  GRP-VB-PC.
  13974. 028900         05  PREV-CNTL-2.
  13975. 029000             07  DS-VB-PC          PIC XX.
  13976. 029100             07  RA-VB-PC         PIC XX.
  13977. 029200             07  PU-VB-PC        PIC XX.
  13978. 029300             07  LINE-VB-PC        PIC X(04).
  13979. 029400         05  FILLER            PIC X(7).
  13980. 029500     03  GRP-VR-PC REDEFINES GRP-VB-PC.
  13981. 029600         05  PREV-CNTL-3.
  13982. 029700             07  RNG-SITE-VR-PC   PIC X(11).
  13983. 029800             07  FMT-NUM-CD-VR-PC   PIC XX.
  13984. 029900             07  LINE-VR-PC        PIC XXXX.
  13985. 030000 01  LINE-CTL.
  13986. 030100     03  REC-LC        PIC XX.
  13987. 030200     03  SDRP-LC.
  13988. 030300         05  ST-LC     PIC XX.
  13989. 030400         05  DS-LC     PIC XX.
  13990. 030500         05  RA-LC     PIC XX.
  13991. 030600         05  PU-LC     PIC XX.
  13992. 030700     03  RNG-SITE-LC   PIC X(11).
  13993. 030800     03  FMT-NUM-LC    PIC X.
  13994. 030900 01  LINE-CTL-HLD   PIC X(22).
  13995. 031000 01  VB1K-RCD.
  13996. 031100     02  REC-TYP-VB1K           PIC X(02).
  13997. 031200     02  FMT-NUM-VB1K           PIC X(01).
  13998. 031300     02  FMT-CD-VB1K            PIC X(01).
  13999. 031400     02  SDRP-VB1K.
  14000. 031500      03 BLM-ADM-U-ST-VB1K      PIC X(02).
  14001. 031600      03 BLM-ADM-U-DIST-VB1K    PIC X(02).
  14002. 031700      03 BLM-ADM-U-RA-VB1K      PIC X(02).
  14003. 031800      03 BLM-ADM-U-PLU-VB1K     PIC X(02).
  14004. 031900     02  CLMTC-ADJ-FCTR-VB1K    PIC X(05).
  14005. 032000     02  DATA-DATE-VB1K         PIC X(06).
  14006. 032100     02  ACTN-CD-VB1K           PIC X(01).
  14007. 032200     02  LIN-NUM-VB1K           PIC X(04).
  14008. 032300     02  SWA-VB1K               PIC X(04).
  14009. 032400     02  TRN-NUM-VB1K           PIC X(02).
  14010. 032500     02  SWA-PCT-VB1K           PIC X(03).
  14011. 032600     02  RNG-SITE-ID-VB1K       PIC X(11).
  14012. 032700     02  STRATUM-NUM-VB1K       PIC X(04).
  14013. 032800     02  ALLOT-NUM-VB1K         PIC X(04).
  14014. 032900     02  PASTURE-NUM-VB1K       PIC X(02).
  14015. 033000     02  VEG-SUB-TYP-VB1K       PIC X(04).
  14016. 033100     02  RNG-ECOL-COND-CLS-VB1K PIC X(01).
  14017. 033200     02  PCT-SPL-VB1K           PIC X(03).
  14018. 033300     02  ASPT-VB1K              PIC X(02).
  14019. 033400     02  L-FORM-VB1K            PIC X(03).
  14020. 033500     02  SOIL-PHAS-VB1K         PIC X(05).
  14021. 033600     02      FIL                 PIC X(20).
  14022. 033700 01  VR1K-RCD.
  14023. 033800     02  VR1K-CTL.
  14024. 033900         03  REC-TYP-VR1K        PIC X(02).
  14025. 034000         03  FMT-NUM-VR1K        PIC X(01).
  14026. 034100         03  FMT-CD-VR1K         PIC X(01).
  14027. 034200         03  BLM-ADM-U-ST-VR1K   PIC X(02).
  14028. 034300     02  FIL                     PIC X(06).
  14029. 034400     02  DATA-DATE-VR1K          PIC X(06).
  14030. 034500     02  ACTN-CD-VR1K            PIC X(01).
  14031. 034600     02  RNG-SITE-ID-VR1K        PIC X(11).
  14032. 034700     02  LIN-NUM-VR1K            PIC X(04).
  14033. 034800     02  RNG-SITE-NAM-VR1K       PIC X(08).
  14034. 034900     02  PRECIP-ZONE-VR1K        PIC X(04).
  14035. 035000     02  SSF-VAL-AVG-VR1K        PIC X(03).
  14036. 035100     02  POTN-PPA-RS-GRP-VR1K.
  14037. 035200         03  POTN-PPA-RS-VR1K OCCURS 3 TIMES
  14038. 035300                                 PIC X(06).
  14039. 035400     02  FIL                     PIC X(29).
  14040. 035500 01  VR2K-RCD.
  14041. 035600     02  VR2K-CTL.
  14042. 035700         03  REC-TYP-VR2K        PIC X(02).
  14043. 035800         03  FMT-NUM-VR2K        PIC X(01).
  14044. 035900         03  FMT-CD-VR2K         PIC X(01).
  14045. 036000         03  BLM-ADM-U-ST-VR2K   PIC X(02).
  14046. 036100     02  FIL                     PIC X(06).
  14047. 036200     02  DATA-DATE-VR2K          PIC X(06).
  14048. 036300     02  ACTN-CD-VR2K            PIC X(01).
  14049. 036400     02  RNG-SITE-ID-VR2K        PIC X(11).
  14050. 036500     02  LIN-NUM-VR2K            PIC X(04).
  14051. 036600     02  PLANT-POTN-VR2K OCCURS 4 TIMES.
  14052. 036700         03  PLANT-CD-VR2K       PIC X(07).
  14053. 036800         03  POTN-PPA-RS-PCT-VR2K PIC X(03).
  14054. 036900     02  PLANT-TYP-VR2K          PIC X(01) OCCURS 4 TIMES.
  14055. 037000     02  FIL                     PIC X(18).
  14056. 037100 01  VR3K-RCD.
  14057. 037200     02  VR3K-CTL.
  14058. 037300         03  REC-TYP-VR3K        PIC X(02).
  14059. 037400         03  FMT-NUM-VR3K        PIC X(01).
  14060. 037500         03  FMT-CD-VR3K         PIC X(01).
  14061. 037600         03  BLM-ADM-U-ST-VR3K   PIC X(02).
  14062. 037700     02  FIL                     PIC X(06).
  14063. 037800     02  DATA-DATE-VR3K          PIC X(06).
  14064. 037900     02  ACTN-CD-VR3K            PIC X(01).
  14065. 038000     02  RNG-SITE-ID-VR3K        PIC X(11).
  14066. 038100     02  LIN-NUM-VR3K            PIC X(04).
  14067. 038200     02  SP-SN-VR3K OCCURS 2 TIMES.
  14068. 038300         03  SOIL-PHAS-VR3K      PIC X(05).
  14069. 038400         03  SOIL-NAM-VR3K       PIC X(24).
  14070. 038500     02  FIL                     PIC X(04).
  14071. 038600 PROCEDURE DIVISION.
  14072. 038700 000-DRIVER SECTION.
  14073. 038800 010-MAINLINE.
  14074. 038900     PERFORM 100-INITIALIZE.
  14075. 039000     PERFORM 200-SORT.
  14076. 039100     PERFORM 990-TERMINATE.
  14077. 039200     STOP RUN.
  14078. 039300*
  14079. 039400 100-INITIALIZE SECTION.
  14080. 039500 110-OPENS.
  14081. 039600     OPEN INPUT PREV-FILE TRAN-FILE
  14082. 039700          OUTPUT NEW-FILE.
  14083. 039800     MOVE ALL "9" TO PREV-CTL.
  14084. 039900     MOVE SPACE TO LINE-CTL LINE-CTL-HLD.
  14085. 040000     ACCEPT TODAYS-DATE FROM DATE.
  14086. 040100     ACCEPT PARAMETER.
  14087. 040200*
  14088. 040300 200-SORT SECTION.
  14089. 040400 210-SORT-VERB.
  14090. 040500     SORT SORT-FILE
  14091. 040600             DESCENDING KEY REC-TYP-SR
  14092. 040700             ASCENDING KEY ST-SR GROUP-VB-SR
  14093. 040800             INPUT PROCEDURE 300-READ-FORMAT
  14094. 040900             OUTPUT PROCEDURE 400-MATCH-UPDATE.
  14095. 041000*
  14096. 041100 300-READ-FORMAT SECTION.
  14097. 041200 310-READ.
  14098. 041300     READ TRAN-FILE
  14099. 041400         AT END GO TO 300-EXIT.
  14100. 041500     MOVE SPACE TO SR-KEY.
  14101. 041600     MOVE REC-TYP-VB-TF TO REC-TYP-SR.
  14102. 041700     MOVE ST-VB-TF TO ST-SR.
  14103. 041800     IF (REC-TYP-VB-TF = "VB")
  14104. 041900         AND (ACTN-VB-TF = SPACE)
  14105. 042000         MOVE "A" TO ACTN-VB-TF.
  14106. 042100     IF (REC-TYP-VB-TF = "VR")
  14107. 042200         AND (ACTN-VR-TF = SPACE)
  14108. 042300         MOVE "A" TO ACTN-VR-TF.
  14109. 042400     IF REC-TYP-VB-TF = "VB"
  14110. 042500             PERFORM 320-BUILD-VB-CTL
  14111. 042600           ELSE
  14112. 042700             PERFORM 330-BUILD-VR-CTL.
  14113. 042800     RELEASE SORT-REC.
  14114. 042900     GO TO 310-READ.
  14115. 043000*
  14116. 043100 320-BUILD-VB-CTL.
  14117. 043200     MOVE DS-VB-TF TO DS-VB-SR.
  14118. 043300     MOVE RA-VB-TF TO RA-VB-SR.
  14119. 043400     MOVE PU-VB-TF TO PU-VB-SR.
  14120. 043500     MOVE ALOT-VB-TF TO ALOT-VB-SR.
  14121. 043600     MOVE PAST-VB-TF TO PAST-VB-SR.
  14122. 043700     MOVE SWAT-VB-TF TO SWAT-VB-SR.
  14123. 043800     MOVE STRATUM-VB-TF TO STRAT-VB-SR.
  14124. 043900     MOVE CAF-VB-TF TO CAF-VB-SR.
  14125. 044000     MOVE LINE-VB-TF TO LINE-VB-SR.
  14126. 044100     IF (LINE-VB-SR = SPACES OR "0000")
  14127. 044200         OR (RELINE-CHK = "YES")
  14128. 044300             MOVE ALL "9" TO LINE-VB-SR, LINE-VB-TF.
  14129. 044400     MOVE REC-VB-TF TO SR-DATA.
  14130. 044500 330-BUILD-VR-CTL.
  14131. 044600     MOVE FMT-NUM-CD-VB-TF TO FMT-NUM-CD-VR-SR.
  14132. 044700     MOVE RNG-SITE-VR-TF TO RNG-SITE-VR-SR.
  14133. 044800     MOVE LINE-VR-TF TO LINE-VR-SR.
  14134. 044900     IF (LINE-VR-SR = SPACES OR "0000")
  14135. 045000         OR (RELINE-CHK = "YES")
  14136. 045100             MOVE ALL "9" TO LINE-VR-SR, LINE-VR-TF.
  14137. 045200     MOVE REC-VR-TF TO SR-DATA.
  14138. 045300 300-EXIT.
  14139. 045400     EXIT.
  14140. 045500*
  14141. 045600 400-MATCH-UPDATE SECTION.
  14142. 045700 410-GET-FIRST-RCDS.
  14143. 045800     PERFORM 430-RETURN-SORT.
  14144. 045900     PERFORM 440-READ-PREV.
  14145. 046000 420-COMPARE.
  14146. 046100     IF TRAN-CTL IS EQUAL TO ALL "9" AND
  14147. 046200        PREV-CTL IS EQUAL TO ALL "9"
  14148. 046300             GO TO 400-EXIT.
  14149. 046400     IF TRAN-CTL IS GREATER THAN PREV-CTL
  14150. 046500             PERFORM 500-NO-TRAN
  14151. 046600             GO TO 420-COMPARE.
  14152. 046700     IF PREV-CTL IS GREATER THAN TRAN-CTL
  14153. 046800             PERFORM 600-NO-PREV
  14154. 046900             GO TO 420-COMPARE.
  14155. 047000     IF TRAN-CTL IS EQUAL TO PREV-CTL
  14156. 047100             PERFORM 700-MATCH.
  14157. 047200     GO TO 420-COMPARE.
  14158. 047300 430-RETURN-SORT.
  14159. 047400     RETURN SORT-FILE AT END
  14160. 047500             MOVE "X" TO END-OF-TRAN.
  14161. 047600     MOVE SORT-KEY-1 TO TRAN-CTL-1.
  14162. 047700*    IF END-OF-TRAN NOT = "X"
  14163. 047800*        DISPLAY SORT-REC.
  14164. 047900     IF REC-TYP-SR IS EQUAL TO "VB"
  14165. 048000         MOVE SR-DATA TO VB1K-RCD
  14166. 048100         MOVE SPACE TO FILLER-TC
  14167. 048200         MOVE SORT-KEY-2 TO TRAN-CTL-2 ELSE
  14168. 048300         MOVE SORT-KEY-3 TO TRAN-CTL-3.
  14169. 048400     IF SR-RT IS EQUAL TO "VR1D"
  14170. 048500             MOVE SR-DATA TO VR1K-RCD.
  14171. 048600     IF SR-RT IS EQUAL TO "VR2D"
  14172. 048700             MOVE SR-DATA TO VR2K-RCD.
  14173. 048800     IF SR-RT IS EQUAL TO "VR3D"
  14174. 048900             MOVE SR-DATA TO VR3K-RCD.
  14175. 049000     IF END-OF-TRAN IS EQUAL TO "X"
  14176. 049100             MOVE ALL "9" TO TRAN-CTL.
  14177. 049200 440-READ-PREV.
  14178. 049300     READ PREV-FILE AT END
  14179. 049400             MOVE "X" TO END-OF-PREV.
  14180. 049500     IF END-OF-PREV NOT = "X"
  14181. 049600         MOVE SPACE TO PREV-CTL.
  14182. 049700     MOVE REC-TYP-VB1X TO REC-TYP-PC.
  14183. 049800     MOVE BLM-ADM-U-ST-VB1X TO ST-PC.
  14184. 049900     IF REC-TYP-VR2X = "VB"
  14185. 050000             PERFORM 450-BUILD-VB-CTL
  14186. 050100           ELSE
  14187. 050200             PERFORM 460-BUILD-VR-CTL.
  14188. 050300     IF END-OF-PREV = "X"
  14189. 050400             MOVE ALL "9" TO PREV-CTL.
  14190. 050500 450-BUILD-VB-CTL.
  14191. 050600     MOVE BLM-ADM-U-DIST-VB1X TO DS-VB-PC.
  14192. 050700     MOVE BLM-ADM-U-RA-VB1X TO RA-VB-PC.
  14193. 050800     MOVE BLM-ADM-U-PLU-VB1X TO PU-VB-PC.
  14194. 050900     MOVE LIN-NUM-VB1X TO LINE-VB-PC.
  14195. 051000 460-BUILD-VR-CTL.
  14196. 051100     MOVE RNG-SITE-ID-VR1X TO RNG-SITE-VR-PC.
  14197. 051200     MOVE LIN-NUM-VR1X TO LINE-VR-PC.
  14198. 051300     MOVE FMT-NUM-CD-VR1X TO FMT-NUM-CD-VR-PC.
  14199. 051400*
  14200. 051500 500-NO-TRAN.
  14201. 051600     MOVE VB1X-RCD     TO VB1Z-RCD.
  14202. 051700     PERFORM 800-ADD-TO-CTRS.
  14203. 051800     IF REC-TYP-VB1Z = "VB"
  14204. 051900             PERFORM 830-CHECK-VB-LIN-NUM THRU 830-OUT
  14205. 052000             MOVE LAST-LIN-NUM TO LIN-NUM-VB1Z
  14206. 052100         ELSE
  14207. 052200             PERFORM 840-CHECK-VR-LIN-NUM THRU 840-OUT
  14208. 052300             MOVE LAST-LIN-NUM TO LIN-NUM-VR1Z.
  14209. 052400     WRITE VB1Z-RCD.
  14210. 052500     PERFORM 440-READ-PREV.
  14211. 052600 600-NO-PREV.
  14212. 052700     MOVE SR-DATA      TO VB1Z-RCD.
  14213. 052800     PERFORM 800-ADD-TO-CTRS.
  14214. 052900     IF REC-TYP-VB1Z = "VB"
  14215. 053000             PERFORM 830-CHECK-VB-LIN-NUM THRU 830-OUT
  14216. 053100             MOVE LAST-LIN-NUM TO LIN-NUM-VB1Z
  14217. 053200         ELSE
  14218. 053300             PERFORM 840-CHECK-VR-LIN-NUM THRU 840-OUT
  14219. 053400             MOVE LAST-LIN-NUM TO LIN-NUM-VR1Z.
  14220. 053500     PERFORM 890-EDIT-DATE.
  14221. 053600
  14222. 053700     WRITE VB1Z-RCD.
  14223. 053800     PERFORM 430-RETURN-SORT.
  14224. 053900 700-MATCH.
  14225. 054000     MOVE VB1X-RCD     TO VB1Z-RCD.
  14226. 054100     PERFORM 890-EDIT-DATE.
  14227. 054200     IF SR-DATA-3 NOT = SPACES AND
  14228. 054300        REC-TYP-VB1Z = "VB"
  14229. 054400             PERFORM 850-MOVE-VB-FIELDS
  14230. 054500             PERFORM 830-CHECK-VB-LIN-NUM THRU 830-OUT
  14231. 054600             MOVE LAST-LIN-NUM TO LIN-NUM-VB1Z
  14232. 054700             PERFORM 800-ADD-TO-CTRS
  14233. 054800             MOVE "A" TO ACTN-CD-VB1Z
  14234. 054900             WRITE VB1Z-RCD.
  14235. 055000     IF SR-DATA-2 NOT = SPACES AND SR-DATA-3 NOT = SPACES AND
  14236. 055100        REC-TYP-VB1Z = "VR"    AND
  14237. 055200        FMT-NUM-VB1Z = "1"
  14238. 055300             PERFORM 860-MOVE-VR1-FIELDS
  14239. 055400             PERFORM 840-CHECK-VR-LIN-NUM THRU 840-OUT
  14240. 055500             MOVE LAST-LIN-NUM TO LIN-NUM-VR1Z
  14241. 055600             PERFORM 800-ADD-TO-CTRS
  14242. 055700             MOVE "A" TO ACTN-CD-VR1Z
  14243. 055800             WRITE VB1Z-RCD.
  14244. 055900     IF SR-DATA-2 NOT = SPACES AND SR-DATA-3 NOT = SPACES AND
  14245. 056000        REC-TYP-VB1Z = "VR"    AND
  14246. 056100        FMT-NUM-VB1Z = "2"
  14247. 056200             PERFORM 870-MOVE-VR2-FIELDS
  14248. 056300             PERFORM 840-CHECK-VR-LIN-NUM THRU 840-OUT
  14249. 056400             MOVE LAST-LIN-NUM TO LIN-NUM-VR1Z
  14250. 056500             PERFORM 800-ADD-TO-CTRS
  14251. 056600             MOVE "A" TO ACTN-CD-VR2Z
  14252. 056700             WRITE VB1Z-RCD.
  14253. 056800     IF SR-DATA-2 NOT = SPACES AND SR-DATA-3 NOT = SPACES AND
  14254. 056900        REC-TYP-VB1X = "VR"    AND
  14255. 057000        FMT-NUM-VB1X = "3"
  14256. 057100             PERFORM 880-MOVE-VR3-FIELDS
  14257. 057200             PERFORM 840-CHECK-VR-LIN-NUM THRU 840-OUT
  14258. 057300             MOVE LAST-LIN-NUM TO LIN-NUM-VR1Z
  14259. 057400             PERFORM 800-ADD-TO-CTRS
  14260. 057500             MOVE "A" TO ACTN-CD-VR3Z
  14261. 057600             WRITE VB1Z-RCD.
  14262. 057700     PERFORM 430-RETURN-SORT.
  14263. 057800     PERFORM 440-READ-PREV.
  14264. 057900 800-ADD-TO-CTRS.
  14265. 058000     IF REC-TYP-VB1Z = "VB"
  14266. 058100         ADD 1 TO VB1-CTR.
  14267. 058200     IF REC-TYP-VB1Z = "VR" AND
  14268. 058300        FMT-NUM-VB1Z = "1"
  14269. 058400             ADD 1 TO VR1-CTR.
  14270. 058500     IF REC-TYP-VB1Z = "VR" AND
  14271. 058600        FMT-NUM-VB1Z = "2"
  14272. 058700             ADD 1 TO VR2-CTR.
  14273. 058800     IF REC-TYP-VB1Z = "VR" AND
  14274. 058900        FMT-NUM-VB1Z = "3"
  14275. 059000             ADD 1 TO VR3-CTR.
  14276. 059100 810-BUILD-VB-LIN-NUM.
  14277. 059200     IF (LIN-NUM-VB1Z NOT NUMERIC) OR
  14278. 059300         (LIN-NUM-VB1Z = "0000")
  14279. 059400         MOVE "9999" TO LIN-NUM-VB1Z.
  14280. 059500 820-BUILD-VR-LIN-NUM.
  14281. 059600     IF (LIN-NUM-VR1Z NOT NUMERIC) OR
  14282. 059700        (LIN-NUM-VR1Z = "0000")
  14283. 059800         MOVE "9999" TO LIN-NUM-VR1Z.
  14284. 059900 830-CHECK-VB-LIN-NUM.
  14285. 060000     MOVE SPACE TO LINE-CTL.
  14286. 060100     MOVE REC-TYP-VB1Z TO REC-LC.
  14287. 060200     MOVE SDRP-VB1Z TO SDRP-LC.
  14288. 060300     IF LIN-NUM-VB1Z NOT = ALL "9"
  14289. 060400         MOVE LINE-CTL TO LINE-CTL-HLD
  14290. 060500         MOVE LIN-NUM-VB1Z TO LAST-LIN-NUM
  14291. 060600         GO TO 830-OUT.
  14292. 060700     IF LINE-CTL NOT = LINE-CTL-HLD
  14293. 060800         MOVE LINE-CTL TO LINE-CTL-HLD
  14294. 060900         MOVE 0001 TO LAST-LIN-NUM
  14295. 061000       ELSE
  14296. 061100         ADD 1 TO LAST-LIN-NUM.
  14297. 061200 830-OUT.
  14298. 061300     EXIT.
  14299. 061400 840-CHECK-VR-LIN-NUM.
  14300. 061500     MOVE SPACE TO LINE-CTL.
  14301. 061600     MOVE REC-TYP-VR1Z TO REC-LC.
  14302. 061700     MOVE BLM-ADM-U-ST-VR1Z TO ST-LC.
  14303. 061800     MOVE RNG-SITE-ID-VR1Z TO RNG-SITE-LC.
  14304. 061900     MOVE FMT-NUM-VR1Z TO FMT-NUM-LC.
  14305. 062000     IF LIN-NUM-VR1Z NOT = ALL "9"
  14306. 062100         MOVE LINE-CTL TO LINE-CTL-HLD
  14307. 062200         MOVE LIN-NUM-VR1Z TO LAST-LIN-NUM
  14308. 062300         GO TO 840-OUT.
  14309. 062400     IF LINE-CTL NOT = LINE-CTL-HLD
  14310. 062500         MOVE LINE-CTL TO LINE-CTL-HLD
  14311. 062600         MOVE 0001 TO LAST-LIN-NUM
  14312. 062700       ELSE
  14313. 062800         ADD 1 TO LAST-LIN-NUM.
  14314. 062900 840-OUT.
  14315. 063000     EXIT.
  14316. 063100*
  14317. 063200 850-MOVE-VB-FIELDS.
  14318. 063300     IF SWA-VB1K       = SPACES
  14319. 063400             NEXT SENTENCE
  14320. 063500       ELSE
  14321. 063600           IF SWA-VB1K       = "****"
  14322. 063700                  MOVE SPACES TO SWA-VB1Z
  14323. 063800                ELSE
  14324. 063900                  MOVE SWA-VB1K TO SWA-VB1Z.
  14325. 064000     IF TRN-NUM-VB1K = SPACES
  14326. 064100             NEXT SENTENCE
  14327. 064200             ELSE
  14328. 064300             IF TRN-NUM-VB1K = "**"
  14329. 064400                  MOVE SPACES TO TRN-NUM-VB1Z
  14330. 064500                  MOVE TRN-NUM-VB1K TO TRN-NUM-VB1Z.
  14331. 064600     IF SWA-PCT-VB1K = SPACES
  14332. 064700             NEXT SENTENCE
  14333. 064800             ELSE
  14334. 064900             IF SWA-PCT-VB1K = "***"
  14335. 065000                  MOVE SPACES TO SWA-PCT-VB1Z
  14336. 065100                  ELSE
  14337. 065200                  MOVE SWA-PCT-VB1K TO SWA-PCT-VB1Z.
  14338. 065300     IF RNG-SITE-ID-VB1K = SPACES
  14339. 065400             NEXT SENTENCE
  14340. 065500             ELSE
  14341. 065600             IF RNG-SITE-ID-VB1K = "***********"
  14342. 065700                  MOVE SPACES TO RNG-SITE-ID-VB1Z
  14343. 065800                  ELSE
  14344. 065900                  MOVE RNG-SITE-ID-VB1K TO RNG-SITE-ID-VB1Z.
  14345. 066000     IF STRATUM-NUM-VB1K = "****"
  14346. 066100             MOVE SPACES TO STRATUM-NUM-VB1Z STRATUM-NUM-VB1K.
  14347. 066200     IF STRATUM-NUM-VB1K  NOT = SPACES
  14348. 066300                  MOVE STRATUM-NUM-VB1K TO STRATUM-NUM-VB1Z.
  14349. 066400     IF ALLOT-NUM-VB1K = SPACES
  14350. 066500             NEXT SENTENCE
  14351. 066600             ELSE
  14352. 066700             IF ALLOT-NUM-VB1K = "****"
  14353. 066800                  MOVE SPACES TO ALLOT-NUM-VB1Z
  14354. 066900                  ELSE
  14355. 067000                  MOVE ALLOT-NUM-VB1K TO ALLOT-NUM-VB1Z.
  14356. 067100     IF PASTURE-NUM-VB1K = SPACES
  14357. 067200             NEXT SENTENCE
  14358. 067300             ELSE
  14359. 067400             IF PASTURE-NUM-VB1K = "**"
  14360. 067500                  MOVE SPACES TO PASTURE-NUM-VB1Z
  14361. 067600                  ELSE
  14362. 067700                  MOVE PASTURE-NUM-VB1K TO PASTURE-NUM-VB1Z.
  14363. 067800     IF VEG-SUB-TYP-VB1K = SPACES
  14364. 067900             NEXT SENTENCE
  14365. 068000             ELSE
  14366. 068100             IF VEG-SUB-TYP-VB1K = "****"
  14367. 068200                  MOVE SPACES TO VEG-SUB-TYP-VB1Z
  14368. 068300                  ELSE
  14369. 068400                  MOVE VEG-SUB-TYP-VB1K TO VEG-SUB-TYP-VB1Z.
  14370. 068500     IF RNG-ECOL-COND-CLS-VB1K = SPACES
  14371. 068600             NEXT SENTENCE
  14372. 068700             ELSE
  14373. 068800             IF RNG-ECOL-COND-CLS-VB1K = "*"
  14374. 068900                  MOVE SPACES TO RNG-ECOL-COND-CLS-VB1Z
  14375. 069000                  ELSE
  14376. 069100                  MOVE RNG-ECOL-COND-CLS-VB1K TO
  14377. 069200                       RNG-ECOL-COND-CLS-VB1Z.
  14378. 069300     IF PCT-SPL-VB1K = SPACES
  14379. 069400             NEXT SENTENCE
  14380. 069500             ELSE
  14381. 069600             IF PCT-SPL-VB1K = "***"
  14382. 069700                  MOVE SPACES TO PCT-SPL-VB1Z
  14383. 069800                  ELSE
  14384. 069900                  MOVE PCT-SPL-VB1K TO PCT-SPL-VB1Z.
  14385. 070000     IF ASPT-VB1K = SPACES
  14386. 070100             NEXT SENTENCE
  14387. 070200             ELSE
  14388. 070300             IF ASPT-VB1K = "**"
  14389. 070400                  MOVE SPACES TO ASPT-VB1Z
  14390. 070500                  ELSE
  14391. 070600                  MOVE ASPT-VB1K TO ASPT-VB1Z.
  14392. 070700     IF L-FORM-VB1K = SPACES
  14393. 070800             NEXT SENTENCE
  14394. 070900             ELSE
  14395. 071000             IF L-FORM-VB1K = "***"
  14396. 071100                  MOVE SPACES TO L-FORM-VB1Z
  14397. 071200                  ELSE
  14398. 071300                  MOVE L-FORM-VB1K TO L-FORM-VB1Z.
  14399. 071400     IF SOIL-PHAS-VB1K = SPACES
  14400. 071500             NEXT SENTENCE
  14401. 071600             ELSE
  14402. 071700             IF SOIL-PHAS-VB1K = "*****"
  14403. 071800                  MOVE SPACES TO SOIL-PHAS-VB1Z
  14404. 071900                  ELSE
  14405. 072000                  MOVE SOIL-PHAS-VB1K TO SOIL-PHAS-VB1Z.
  14406. 072100 860-MOVE-VR1-FIELDS.
  14407. 072200     IF RNG-SITE-NAM-VR1K = SPACES
  14408. 072300             NEXT SENTENCE
  14409. 072400             ELSE
  14410. 072500             IF RNG-SITE-NAM-VR1K = "********"
  14411. 072600                  MOVE SPACES TO RNG-SITE-NAM-VR1Z
  14412. 072700                  ELSE
  14413. 072800                  MOVE RNG-SITE-NAM-VR1K TO RNG-SITE-NAM-VR1Z.
  14414. 072900     IF PRECIP-ZONE-VR1K = SPACES
  14415. 073000             NEXT SENTENCE
  14416. 073100             ELSE
  14417. 073200             IF PRECIP-ZONE-VR1K = "****"
  14418. 073300                  MOVE SPACES TO PRECIP-ZONE-VR1Z
  14419. 073400                  ELSE
  14420. 073500                  MOVE PRECIP-ZONE-VR1K TO PRECIP-ZONE-VR1Z.
  14421. 073600     IF SSF-VAL-AVG-VR1K = SPACES
  14422. 073700             NEXT SENTENCE
  14423. 073800             ELSE
  14424. 073900             IF SSF-VAL-AVG-VR1K = "***"
  14425. 074000                  MOVE SPACES TO SSF-VAL-AVG-VR1Z
  14426. 074100                  ELSE
  14427. 074200                  MOVE SSF-VAL-AVG-VR1K TO SSF-VAL-AVG-VR1Z.
  14428. 074300     IF POTN-PPA-RS-VR1K (2) = SPACES
  14429. 074400             NEXT SENTENCE
  14430. 074500             ELSE
  14431. 074600             IF POTN-PPA-RS-VR1K (2) = "******"
  14432. 074700                 MOVE SPACES TO POTN-PPA-RS-VR1Z (2)
  14433. 074800                 ELSE
  14434. 074900                 MOVE POTN-PPA-RS-VR1K (2) TO
  14435. 075000                      POTN-PPA-RS-VR1Z (2).
  14436. 075100     IF POTN-PPA-RS-VR1K (3) = SPACES
  14437. 075200             NEXT SENTENCE
  14438. 075300             ELSE
  14439. 075400             IF POTN-PPA-RS-VR1K (3) = "******"
  14440. 075500                 MOVE SPACES TO POTN-PPA-RS-VR1Z (3)
  14441. 075600                 ELSE
  14442. 075700                 MOVE POTN-PPA-RS-VR1K (3) TO
  14443. 075800                      POTN-PPA-RS-VR1Z (3).
  14444. 075900     IF POTN-PPA-RS-VR1K (1) = SPACES
  14445. 076000             NEXT SENTENCE
  14446. 076100             ELSE
  14447. 076200             IF POTN-PPA-RS-VR1K (1) = "******"
  14448. 076300                 MOVE SPACES TO POTN-PPA-RS-VR1Z (1)
  14449. 076400                 ELSE
  14450. 076500                 MOVE POTN-PPA-RS-VR1K (1) TO
  14451. 076600                      POTN-PPA-RS-VR1Z (1).
  14452. 076700 870-MOVE-VR2-FIELDS.
  14453. 076800     IF PLANT-CD-VR2K (1) = SPACES
  14454. 076900             NEXT SENTENCE
  14455. 077000             ELSE
  14456. 077100             IF PLANT-CD-VR2K (1) = "*******"
  14457. 077200                 MOVE SPACES TO PLANT-CD-VR2Z (1)
  14458. 077300                 ELSE
  14459. 077400                 MOVE PLANT-CD-VR2K (1) TO PLANT-CD-VR2Z (1).
  14460. 077500     IF POTN-PPA-RS-PCT-VR2K (1) = SPACES
  14461. 077600             NEXT SENTENCE
  14462. 077700             ELSE
  14463. 077800             IF POTN-PPA-RS-PCT-VR2K (1) = "***"
  14464. 077900                 MOVE SPACES TO POTN-PPA-RS-PCT-VR2K (1)
  14465. 078000                 ELSE
  14466. 078100                 MOVE POTN-PPA-RS-PCT-VR2K (1) TO
  14467. 078200                      POTN-PPA-RS-PCT-VR2K (1).
  14468. 078300     IF PLANT-CD-VR2K (2) = SPACES
  14469. 078400             NEXT SENTENCE
  14470. 078500             ELSE
  14471. 078600             IF PLANT-CD-VR2K (2) = "*******"
  14472. 078700                 MOVE SPACES TO PLANT-CD-VR2Z (2)
  14473. 078800                 ELSE
  14474. 078900                 MOVE PLANT-CD-VR2K (2) TO PLANT-CD-VR2Z (2).
  14475. 079000     IF POTN-PPA-RS-PCT-VR2K (2) = SPACES
  14476. 079100             NEXT SENTENCE
  14477. 079200             ELSE
  14478. 079300             IF POTN-PPA-RS-PCT-VR2K (2) = "***"
  14479. 079400                 MOVE SPACES TO POTN-PPA-RS-PCT-VR2K (2)
  14480. 079500                 ELSE
  14481. 079600                 MOVE POTN-PPA-RS-PCT-VR2K (2) TO
  14482. 079700                      POTN-PPA-RS-PCT-VR2K (2).
  14483. 079800     IF PLANT-CD-VR2K (3) = SPACES
  14484. 079900             NEXT SENTENCE
  14485. 080000             ELSE
  14486. 080100             IF PLANT-CD-VR2K (3) = "*******"
  14487. 080200                 MOVE SPACES TO PLANT-CD-VR2Z (3)
  14488. 080300                 ELSE
  14489. 080400                 MOVE PLANT-CD-VR2K (3) TO PLANT-CD-VR2Z (3).
  14490. 080500     IF POTN-PPA-RS-PCT-VR2K (3) = SPACES
  14491. 080600             NEXT SENTENCE
  14492. 080700             ELSE
  14493. 080800             IF POTN-PPA-RS-PCT-VR2K (3) = "***"
  14494. 080900                 MOVE SPACES TO POTN-PPA-RS-PCT-VR2Z (3)
  14495. 081000                 ELSE
  14496. 081100                 MOVE POTN-PPA-RS-PCT-VR2K (3) TO
  14497. 081200                      POTN-PPA-RS-PCT-VR2Z (3).
  14498. 081300     IF PLANT-TYP-VR2K (1) = SPACES
  14499. 081400             NEXT SENTENCE
  14500. 081500             ELSE
  14501. 081600             IF PLANT-TYP-VR2K (1) = "*"
  14502. 081700                  MOVE SPACES TO PLANT-TYP-VR2Z (1)
  14503. 081800                  ELSE
  14504. 081900                  MOVE PLANT-TYP-VR2K (1) TO PLANT-TYP-VR2Z (1).
  14505. 082000     IF PLANT-TYP-VR2K (2) = SPACES
  14506. 082100             NEXT SENTENCE
  14507. 082200             ELSE
  14508. 082300             IF PLANT-TYP-VR2K (2) = "*"
  14509. 082400                  MOVE SPACES TO PLANT-TYP-VR2Z (2)
  14510. 082500                  ELSE
  14511. 082600                  MOVE PLANT-TYP-VR2K (2) TO PLANT-TYP-VR2Z (2).
  14512. 082700     IF PLANT-TYP-VR2K (3) = SPACES
  14513. 082800             NEXT SENTENCE
  14514. 082900             ELSE
  14515. 083000             IF PLANT-TYP-VR2K (3) = "*"
  14516. 083100                  MOVE SPACES TO PLANT-TYP-VR2Z (3)
  14517. 083200                  ELSE
  14518. 083300                  MOVE PLANT-TYP-VR2K (3) TO PLANT-TYP-VR2Z (3).
  14519. 083400     IF PLANT-TYP-VR2K (4) = SPACES
  14520. 083500             NEXT SENTENCE
  14521. 083600             ELSE
  14522. 083700             IF PLANT-TYP-VR2K (4) = "*"
  14523. 083800                  MOVE SPACES TO PLANT-TYP-VR2Z (4)
  14524. 083900                  ELSE
  14525. 084000                  MOVE PLANT-TYP-VR2K (4) TO PLANT-TYP-VR2Z (4).
  14526. 084100 880-MOVE-VR3-FIELDS.
  14527. 084200     IF SOIL-PHAS-VR3K (1) = SPACES
  14528. 084300             NEXT SENTENCE
  14529. 084400             ELSE
  14530. 084500             IF SOIL-PHAS-VR3K (1) = "*****"
  14531. 084600                 MOVE SPACES TO SOIL-PHAS-VR3Z (1)
  14532. 084700                 ELSE
  14533. 084800                 MOVE SOIL-PHAS-VR3K (1) TO SOIL-PHAS-VR3Z (1).
  14534. 084900     IF SOIL-NAM-VR3K (1) = SPACES
  14535. 085000             NEXT SENTENCE
  14536. 085100             ELSE
  14537. 085200             IF SOIL-NAM-VR3K (1) = "*************************"
  14538. 085300                 MOVE SPACES TO SOIL-NAM-VR3Z (1)
  14539. 085400                 ELSE
  14540. 085500                 MOVE SOIL-NAM-VR3K (1) TO SOIL-NAM-VR3Z (1).
  14541. 085600     IF SOIL-PHAS-VR3K (2) = SPACES
  14542. 085700             NEXT SENTENCE
  14543. 085800             ELSE
  14544. 085900             IF SOIL-PHAS-VR3K (2) = "*****"
  14545. 086000                 MOVE SPACES TO SOIL-PHAS-VR3Z (2)
  14546. 086100                 ELSE
  14547. 086200                 MOVE SOIL-PHAS-VR3K (2) TO SOIL-PHAS-VR3Z (2).
  14548. 086300     IF SOIL-NAM-VR3K (2) = SPACES
  14549. 086400             NEXT SENTENCE
  14550. 086500             ELSE
  14551. 086600             IF SOIL-NAM-VR3K (2) = "*************************"
  14552. 086700                 MOVE SPACES TO SOIL-NAM-VR3Z (2)
  14553. 086800                 ELSE
  14554. 086900                 MOVE SOIL-NAM-VR3K (2) TO SOIL-NAM-VR3Z (2).
  14555. 087000*
  14556. 087100 890-EDIT-DATE.
  14557. 087200     MOVE SPACE TO DATE-MV-SW.
  14558. 087300     IF REC-TYP-VB1Z = "VB"
  14559. 087400             MOVE DATA-DATE-VB1Z TO DATE-WORK
  14560. 087500           ELSE
  14561. 087600             MOVE DATA-DATE-VR1Z TO DATE-WORK.
  14562. 087700     PERFORM 900-EDIT-FIELDS.
  14563. 087800     IF DATE-SW NOT = " "
  14564. 087900             PERFORM 910-SWITCH-FIELDS
  14565. 088000             PERFORM 900-EDIT-FIELDS.
  14566. 088100     IF DATE-SW NOT = " " AND
  14567. 088200        REC-TYP-VB1Z = "VB"
  14568. 088300             MOVE TODAYS-DATE TO DATA-DATE-VB1Z.
  14569. 088400     IF DATE-SW NOT = " " AND
  14570. 088500        REC-TYP-VB1Z = "VR"
  14571. 088600             MOVE TODAYS-DATE TO DATA-DATE-VR1Z.
  14572. 088700     IF DATE-MV-SW NOT = " " AND
  14573. 088800        REC-TYP-VB1Z = "VB"
  14574. 088900             MOVE MOVED-DATE  TO DATA-DATE-VB1Z.
  14575. 089000     IF DATE-MV-SW NOT = " " AND
  14576. 089100        REC-TYP-VB1Z = "VR"
  14577. 089200             MOVE MOVED-DATE  TO DATA-DATE-VR1Z.
  14578. 089300 900-EDIT-FIELDS.
  14579. 089400     MOVE SPACE TO DATE-SW.
  14580. 089500     IF DW-MM NOT NUMERIC OR
  14581. 089600        DW-MM > "12"      OR
  14582. 089700        DW-MM < "01"
  14583. 089800             MOVE "X" TO DATE-SW.
  14584. 089900     IF DW-DD NOT NUMERIC OR
  14585. 090000        DW-DD < "01"      OR
  14586. 090100        DW-DD > "31"
  14587. 090200             MOVE "X" TO DATE-SW.
  14588. 090300     IF DW-YY NOT NUMERIC OR
  14589. 090400        DW-YY < "78"
  14590. 090500             MOVE "X" TO DATE-SW.
  14591. 090600 910-SWITCH-FIELDS.
  14592. 090700     IF DW-DD = "78" OR "79" OR "80" OR "81" OR "82"
  14593. 090800             MOVE DW-MM TO MD-MM
  14594. 090900             MOVE DW-DD TO MD-DD
  14595. 091000             MOVE DW-YY TO MD-YY
  14596. 091100             MOVE "X"   TO DATE-MV-SW.
  14597. 091200 400-EXIT.
  14598. 091300     EXIT.
  14599. 091400*
  14600. 091500 990-TERMINATE SECTION.
  14601. 091600 990-PRINT.
  14602. 091700     DISPLAY "  VB1    VR1    VR2    VR3".
  14603. 091800     DISPLAY VB1-CTR "  " VR1-CTR "  " VR2-CTR "  " VR3-CTR.
  14604. 091900 990-CLOSE.
  14605. 092000     CLOSE PREV-FILE TRAN-FILE NEW-FILE.
  14606. 000000*-----------------------------------------------------------------
  14607. 000100 IDENTIFICATION DIVISION.
  14608. 000200 PROGRAM-ID. ES315P.
  14609. 000300*        VB / VR VERIFICATION LIST
  14610. 000400*
  14611. 000500 AUTHOR. CORA FISCHER.
  14612. 000600 INSTALLATION.
  14613. 000700 DATE-WRITTEN.  8/8/80.
  14614. 000800 DATE-COMPILED.
  14615. 000900 ENVIRONMENT DIVISION.
  14616. 001000 CONFIGURATION SECTION.
  14617. 001100 SOURCE-COMPUTER. LEVEL-66-ASCII.
  14618. 001200 OBJECT-COMPUTER. LEVEL-66-ASCII.
  14619. 001300 INPUT-OUTPUT SECTION.
  14620. 001400 FILE-CONTROL.
  14621. 001500     SELECT  INPUT-FILE1 ASSIGN TO I1-ES310UD1
  14622. 001600         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  14623. 001700     SELECT  PRINT-FILE ASSIGN TO P1-PRINTER
  14624. 001800         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  14625. 001900     SELECT  SORT-FILE ASSIGN TO S1.
  14626. 002000 DATA DIVISION.
  14627. 002100 SUB-SCHEMA SECTION.
  14628. 002200 DB  CODVAL2 WITHIN BLMDIC.
  14629. 002300 FILE SECTION.
  14630. 002400 FD  INPUT-FILE1       CODE-SET IS GBCD
  14631. 002500                       LABEL RECORDS ARE STANDARD
  14632. 002600                       DATA RECORDS ARE FDR-VB  FDR-VR1
  14633. 002700                         FDR-VR2  FDR-VR3.
  14634. 002800 01  FDR-VB.
  14635. 002900     03  REC-TYPE-3529-VB-I1               PIC       X(02).
  14636. 003000     03  FMT-NO-3576-VB-I1                 PIC       X(01).
  14637. 003100     03  FMT-CD-3579-VB-I1                 PIC       X(01).
  14638. 003200     03  ADM-UNIT-0003-VB-I1.
  14639. 003300         05  ADM-ST-0003-VB-I1             PIC       X(02).
  14640. 003400         05  ADM-DI-0003-VB-I1             PIC       X(02).
  14641. 003500         05  ADM-RA-0003-VB-I1             PIC       X(02).
  14642. 003600         05  ADM-PU-0003-VB-I1             PIC       X(02).
  14643. 003700     03  CLMTC-ADJ-FCTR-3547-VB-I1         PIC       99V999.
  14644. 003800     03  DATA-DT-6618-VB-I1                PIC       X(06).
  14645. 003900     03  ACT-CD-7350-VB-I1                 PIC       X(01).
  14646. 004000     03  LINE-NO-3578-VB-I1                PIC       X(04).
  14647. 004100     03  SWA-3507-VB-I1                    PIC       X(04).
  14648. 004200     03  TRN-NUM-3508-VB-I1                PIC       X(02).
  14649. 004300     03  SWA-PCT-3516-VB-I1                PIC       X(03).
  14650. 004400     03  RNG-SITE-ID-3528-VB-I1            PIC       X(11).
  14651. 004500     03  STRATUM-NUM-3906-VB-I1            PIC       9(04).
  14652. 004600     03  ALLOT-NUM-0968-VB-I1              PIC       X(04).
  14653. 004700     03  PASTURE-NUM-3905-VB-I1            PIC       X(02).
  14654. 004800     03  VEG-SUB-TYPE-2706-VB-I1           PIC       X(04).
  14655. 004900     03  RNG-ECOL-COND-CLS-2625-VB-I1      PIC       X(01).
  14656. 005000     03  PCT-SLP-3874-VB-I1                PIC       X(03).
  14657. 005100     03  ASPT-6523-VB-I1                   PIC        X(02).
  14658. 005200     03  L-FORM-5132-VB-I1                 PIC       X(03).
  14659. 005300     03  SOIL-PHAS-4649-VB-I1              PIC       X(05).
  14660. 005400     03  FILLER                            PIC       X(20).
  14661. 005500 01  FDR-VR1.
  14662. 005600     03  REC-TYPE-3529-VR1-I1              PIC       X(02).
  14663. 005700     03  FMT-NO-3576-VR1-I1                PIC       X(01).
  14664. 005800     03  FMT-CD-3579-VR1-I1                PIC       X(01).
  14665. 005900     03  ADM-UNIT-0003-VR1-I1.
  14666. 006000         05  ADM-ST-0003-VR1-I1            PIC       X(02).
  14667. 006100         05  ADM-DI-0003-VR1-I1            PIC       X(02).
  14668. 006200         05  ADM-RA-0003-VR1-I1            PIC       X(02).
  14669. 006300         05  ADM-PU-0003-VR1-I1            PIC       X(02).
  14670. 006400     03  DATA-DT-6618-VR1-I1               PIC       X(06).
  14671. 006500     03  ACT-CD-7350-VR1-I1                PIC       X(01).
  14672. 006600     03  RNG-SITE-ID-3528-VR1-I1           PIC       X(11).
  14673. 006700     03  FILLER                            PIC       X(04).
  14674. 006800     03  RNG-SITE-NAM-3914-VR1-I1          PIC       X(08).
  14675. 006900     03  PRECIP-ZONE-3909-VR1-I1.
  14676. 007000         05  PRECIP-ZONE-LOW-3909-VR1-I1   PIC       X(02).
  14677. 007100         05  PRECIP-ZONE-HI-3909-VR1-I1    PIC       X(02).
  14678. 007200     03  SSF-VAL-AVG-4818-VR1-I1           PIC       X(03).
  14679. 007300     03  POTN-PPA-3930-VR1-I1    PIC       X(06) OCCURS 3 TIMES.
  14680. 007400     03  FILLER                            PIC       X(29).
  14681. 007500 01  FDR-VR2.
  14682. 007600     03  REC-TYPE-3529-VR2-I1              PIC       X(02).
  14683. 007700     03  FMT-NO-3576-VR2-I1                PIC       X(01).
  14684. 007800     03  FMT-CD-3579-VR2-I1                PIC       X(01).
  14685. 007900     03  ADM-UNIT-0003-VR2-I1.
  14686. 008000         05  ADM-ST-0003-VR2-I1            PIC       X(02).
  14687. 008100         05  ADM-DI-0003-VR2-I1            PIC       X(02).
  14688. 008200         05  ADM-RA-0003-VR2-I1            PIC       X(02).
  14689. 008300         05  ADM-PU-0003-VR2-I1            PIC       X(02).
  14690. 008400     03  DATA-DT-6618-VR2-I1               PIC       X(06).
  14691. 008500     03  ACT-CD-7350-VR2-I1                PIC       X(01).
  14692. 008600     03  RNG-SITE-ID-3528-VR2-I1           PIC       X(11).
  14693. 008700     03  LINE-NO-3578-VR2-I1               PIC       X(04).
  14694. 008800     03  PLANT-CD-POTN-PCT-VR2-I1   OCCURS 4 TIMES.
  14695. 008900         05  PLANT-CD-2646-VR2-I1          PIC       X(07).
  14696. 009000         05  POTN-PCT-3535-VR2-I1          PIC       X(03).
  14697. 009100 01  FDR-VR3.
  14698. 009200     03  REC-TYPE-3529-VR3-I1              PIC       X(02).
  14699. 009300     03  FMT-NO-3576-VR3-I1                PIC       X(01).
  14700. 009400     03  FMT-CD-3579-VR3-I1                PIC       X(01).
  14701. 009500     03  ADM-UNIT-0003-VR3-I1.
  14702. 009600         05  ADM-ST-0003-VR3-I1            PIC       X(02).
  14703. 009700         05  ADM-DI-0003-VR3-I1            PIC       X(02).
  14704. 009800         05  ADM-RA-0003-VR3-I1            PIC       X(02).
  14705. 009900         05  ADM-PU-0003-VR3-I1            PIC       X(02).
  14706. 010000     03  DATA-DT-6618-VR3-I1               PIC       X(06).
  14707. 010100     03  ACT-CD-7350-VR3-I1                PIC       X(01).
  14708. 010200     03  RNG-SITE-ID-3528-VR3-I1           PIC       X(11).
  14709. 010300     03  LINE-NO-3578-VR3-I1               PIC       X(04).
  14710. 010400     03  SOIL-PHASE-NAME-VR3-I1      OCCURS 2 TIMES.
  14711. 010500         05  SOIL-PHAS-4649-VR3-I1         PIC       X(05).
  14712. 010600         05  SOIL-NAM-4648-VR3-I1          PIC       X(24).
  14713. 010700 FD  PRINT-FILE        CODE-SET IS GBCD
  14714. 010800                       LABEL RECORDS ARE STANDARD
  14715. 010900                       DATA RECORD IS PRT-REC.
  14716. 011000 01  PRT-REC                               PIC       X(132).
  14717. 011100 SD  SORT-FILE         DATA RECORDS ARE S-KEY1, S-KEY2,
  14718. 011200                                 S-KEY3, S-KEY4.
  14719. 011300 01  S-KEY1.
  14720. 011400     03  SORT-KEY1-VB.
  14721. 011500       04  S-KEY-1A.
  14722. 011600         05  REC-TYPE-3529-VB-S1           PIC       X(02).
  14723. 011700         05  FMT-NO-3576-VB-S1             PIC       X(01).
  14724. 011800         05  FMT-CD-3579-VB-S1             PIC       X(01).
  14725. 011900       04  S-KEY-2A.
  14726. 012000         05  ADM-UNIT-0003-VB-S1.
  14727. 012100             07  ADM-ST-0003-VB-S1         PIC       X(02).
  14728. 012200             07  ADM-DI-0003-VB-S1         PIC       X(02).
  14729. 012300             07  ADM-RA-0003-VB-S1         PIC       X(02).
  14730. 012400             07  ADM-PU-0003-VB-S1         PIC       X(02).
  14731. 012500         05  ALLOT-NUM-0968-VB-S1          PIC       X(04).
  14732. 012600         05  PASTURE-NUM-3905-VB-S1        PIC       X(02).
  14733. 012700         05  SWA-3507-VB-S1                PIC       X(04).
  14734. 012800         05  TRN-NUM-3508-VB-S1            PIC       X(02).
  14735. 012900         05  STRATUM-NUM-3906-VB-S1        PIC       9(04).
  14736. 013000         05  CLMTC-ADJ-FCTR-3547-VB-S1     PIC       99V999.
  14737. 013100     03  SORT-KEY2-VB.
  14738. 013200         05  DATA-DT-6618-VB-S1            PIC       X(06).
  14739. 013300         05  ACT-CD-7350-VB-S1             PIC       X(01).
  14740. 013400         05  LINE-NO-3578-VB-S1            PIC       9(04).
  14741. 013500         05  SWA-PCT-3516-VB-S1            PIC       X(03).
  14742. 013600         05  RNG-SITE-ID-3528-VB-S1        PIC       X(11).
  14743. 013700         05  VEG-SUB-TYPE-2706-VB-S1       PIC       X(04).
  14744. 013800         05  RNG-ECOL-COND-CLS-2625-VB-S1  PIC       X(01).
  14745. 013900         05  PCT-SLP-3874-VB-S1            PIC       X(03).
  14746. 014000         05  ASPT-6523-VB-S1               PIC       X(02).
  14747. 014100         05  L-FORM-5132-VB-S1             PIC       X(03).
  14748. 014200         05  SOIL-PHAS-4649-VB-S1          PIC       X(05).
  14749. 014300         05  FILLER                        PIC       X(26).
  14750. 014400 01  S-KEY2.
  14751. 014500     03  SORT-KEY1-VR1.
  14752. 014600         05  REC-TYPE-3529-VR1-S1          PIC       X(02).
  14753. 014700         05  FILLER                        PIC       X(01).
  14754. 014800         05  FMT-CD-3579-VR1-S1            PIC       X(01).
  14755. 014900         05  ADM-ST-0003-VR1-S1            PIC       X(02).
  14756. 015000         05  RNG-SITE-ID-3528-VR1-S1       PIC       X(11).
  14757. 015100         05  FMT-NO-3576-VR1-S1            PIC       X(01).
  14758. 015200         05  FILLER                        PIC       X(15).
  14759. 015300     03  SORT-KEY2-VR1.
  14760. 015400         05  DATA-DT-6618-VR1-S1           PIC       X(06).
  14761. 015500         05  ACT-CD-7350-VR1-S1            PIC       X(01).
  14762. 015600         05  RNG-SITE-NAM-3914-VR1-S1      PIC       X(08).
  14763. 015700         05  PRECIP-ZONE-3909-VR1-S1.
  14764. 015800             07  PRECIP-ZONE-LOW-3909-VR1-S1   PIC   X(02).
  14765. 015900             07  PRECIP-ZONE-HI-3909-VR1-S1    PIC   X(02).
  14766. 016000         05  SSF-VAL-AVG-4818-VR1-S1       PIC       X(03).
  14767. 016100         05  POTN-PPA-3930-VR1-S1          PIC       X(06)
  14768. 016200                       OCCURS 3 TIMES.
  14769. 016300         05  FILLER                         PIC       X(29).
  14770. 016400 01  S-KEY3.
  14771. 016500     03  SORT-KEY1-VR2.
  14772. 016600         05  REC-TYPE-3529-VR2-S1          PIC       X(02).
  14773. 016700         05  FILLER                        PIC       X(01).
  14774. 016800         05  FMT-CD-3579-VR2-S1            PIC       X(01).
  14775. 016900         05  ADM-ST-0003-VR2-S1            PIC       X(02).
  14776. 017000         05  RNG-SITE-ID-3528-VR2-S1       PIC       X(11).
  14777. 017100         05  FMT-NO-3576-VR2-S1            PIC       X(01).
  14778. 017200         05  FILLER                        PIC       X(15).
  14779. 017300     03  SORT-KEY2-VR2.
  14780. 017400         05  DATA-DT-6618-VR2-S1  PIC       X(06).
  14781. 017500         05  ACT-CD-7350-VR2-S1   PIC       X(01).
  14782. 017600         05  LINE-NO-3578-VR2-S1           PIC       X(04).
  14783. 017700         05  PLANT-CD-POTN-PCT-VR2-S1  OCCURS 4 TIMES.
  14784. 017800             07  PLANT-CD-2646-VR2-S1      PIC       X(07).
  14785. 017900             07  POTN-PCT-3535-VR2-S1      PIC       X(03).
  14786. 018000         05  FILLER                        PIC       X(18).
  14787. 018100 01  S-KEY4.
  14788. 018200     03  SORT-KEY1-VR3.
  14789. 018300         05  REC-TYPE-3529-VR3-S1          PIC       X(02).
  14790. 018400         05  FILLER                        PIC       X(01).
  14791. 018500         05  FMT-CD-3579-VR3-S1            PIC       X(01).
  14792. 018600         05  ADM-ST-0003-VR3-S1            PIC       X(02).
  14793. 018700         05  RNG-SITE-ID-3528-VR3-S1       PIC       X(11).
  14794. 018800         05  FMT-NO-3576-VR3-S1            PIC       X(01).
  14795. 018900         05  FILLER                        PIC       X(15).
  14796. 019000     03  SORT-KEY2-VR3.
  14797. 019100         05  DATA-DT-6618-VR3-S1  PIC       X(06).
  14798. 019200         05  ACT-CD-7350-VR3-S1   PIC       X(01).
  14799. 019300         05  LINE-NO-3578-VR3-S1           PIC       9(04).
  14800. 019400         05  SOIL-PHASE-NAME-VR3-S1  OCCURS  2 TIMES.
  14801. 019500             07  SOIL-PHAS-4649-VR3-S1     PIC       X(05).
  14802. 019600             07  SOIL-NAM-4648-VR3-S1      PIC       X(24).
  14803. 019700 WORKING-STORAGE SECTION.
  14804. 019800 77  INPUT1-CNT                  PIC       9(07)     VALUE 0.
  14805. 019900 77  PAGE-CNT                    PIC       9(05)     VALUE 0.
  14806. 020000 77  VB-CNT                      PIC       9(07)     VALUE 0.
  14807. 020100 77  VR1-CNT                     PIC       9(07)     VALUE 0.
  14808. 020200 77  VR2-CNT                     PIC       9(07)     VALUE 0.
  14809. 020300 77  VR3-CNT                     PIC       9(07)     VALUE 0.
  14810. 020400 77  LINE-CNT                    PIC       9(02)     VALUE 66.
  14811. 020500 01  SW2-3                       PIC       9(01)     VALUE 0.
  14812. 020600 01  VB-SW                       PIC      9          VALUE 0.
  14813. 020700 01  SW-DET-VR2-3                PIC       9(01)     VALUE 0.
  14814. 020800 01  HLD-KEY-1A-S.
  14815. 020900     03  H-REC-TYPE-S1           PIC       X(02).
  14816. 021000     03  H-FMT-NO-HLD-S1         PIC       X(01).
  14817. 021100     03  H-FMT-CD-HLD-S1         PIC       X(01).
  14818. 021200 01  H-RNG-SITE-NUM-S1           PIC       X(11).
  14819. 021300 01  HLD-REC-TYPE.
  14820. 021400     03  REC-TYPE-HLD            PIC       X(02).
  14821. 021500     03  FMT-NO-HLD              PIC       X(01).
  14822. 021600     03  FMT-CD-HLD              PIC       X(01).
  14823. 021700 01  HLD-RNG-SITE-NUM        PIC       X(11).
  14824. 021800 01  MONTH-TABLE.
  14825. 021900     03  MO-TAB.
  14826. 022000         05  FILLER              PIC       X(03)     VALUE "JAN".
  14827. 022100         05  FILLER              PIC       X(03)     VALUE "FEB".
  14828. 022200         05  FILLER              PIC       X(03)     VALUE "MAR".
  14829. 022300         05  FILLER              PIC       X(03)     VALUE "APR".
  14830. 022400         05  FILLER              PIC       X(03)     VALUE "MAY".
  14831. 022500         05  FILLER              PIC       X(03)     VALUE "JUN".
  14832. 022600         05  FILLER              PIC       X(03)     VALUE "JUL".
  14833. 022700         05  FILLER              PIC       X(03)     VALUE "AUG".
  14834. 022800         05  FILLER              PIC       X(03)     VALUE "SEP".
  14835. 022900         05  FILLER              PIC       X(03)     VALUE "OCT".
  14836. 023000         05  FILLER              PIC       X(03)     VALUE "NOV".
  14837. 023100         05  FILLER              PIC       X(03)     VALUE "DEC".
  14838. 023200     03  MON REDEFINES MO-TAB    PIC       X(03) OCCURS 12 TIMES.
  14839. 023300 01  EOF-SWITCH                  PIC       9    VALUE ZERO.
  14840. 023400     88  EOF                               VALUE 1.
  14841. 023500 01  EOR-SWITCH                  PIC       9    VALUE ZERO.
  14842. 023600     88  EOR                     VALUE 1.
  14843. 023700 01  PARAMETER                   PIC       X(04).
  14844. 023800 01  HLD-DT.
  14845. 023900     03  HOLD-DT.
  14846. 024000         05  YR-DT               PIC       XX.
  14847. 024100         05  MO-DT               PIC       99.
  14848. 024200         05  DY-DT               PIC       XX.
  14849. 024300     03  INV-HLD.
  14850. 024400         05  INV-NM    PIC       X(20).
  14851. 024500         05  ST-DIST-CD.
  14852. 024600             07  ST-CD-HLD       PIC       X(02).
  14853. 024700             07  DI-CD-HLD       PIC       X(02).
  14854. 024800     03  EXPL-HLD.
  14855. 024900         05  DIST-NM-HLD         PIC       X(12).
  14856. 025000     03  FUNC-HLD.
  14857. 025100         05  ST-NM-HLD           PIC       X(10).
  14858. 025200         05  FILLER              PIC       X(14).
  14859. 025300     COPY DBSTATUS IN TPCOBOLIB.
  14860. 025400 01  HDR-1.
  14861. 025500     03  FILLER                  PIC       X(08)     VALUE
  14862. 025600         " DATE:  ".
  14863. 025700     03  HDR-MO                  PIC       X(03).
  14864. 025800     03  FILLER                  PIC       X(01)     VALUE SPACE.
  14865. 025900     03  HDR-DA                  PIC       X(02).
  14866. 026000     03  FILLER                  PIC       X(04)     VALUE ", 19".
  14867. 026100     03  HDR-YR                  PIC       X(02).
  14868. 026200     03  FILLER                  PIC       X(21)     VALUE SPACES.
  14869. 026300     03  FILLER                  PIC       X(47)     VALUE
  14870. 026400         "US DEPT OF INTERIOR - BUREAU OF LAND MANAGEMENT".
  14871. 026500     03  FILLER                  PIC       X(29)     VALUE SPACES.
  14872. 026600     03  FILLER                  PIC       X(07)     VALUE
  14873. 026700         "PAGE:  ".
  14874. 026800     03  HDR-PG                  PIC       ZZ,ZZ9.
  14875. 026900     03  FILLER                  PIC       X(02)     VALUE SPACES.
  14876. 027000 01  HDR-2.
  14877. 027100     03  FILLER                  PIC       X(8)      VALUE
  14878. 027200         "STATE:  ".
  14879. 027300     03  HDR-ST-CD               PIC       X(02).
  14880. 027400     03  FILLER                  PIC       X(04)     VALUE SPACES.
  14881. 027500     03  HDR-ST-NM               PIC       X(10).
  14882. 027600     03  FILLER                  PIC       X(30)     VALUE SPACES.
  14883. 027700     03  FILLER                  PIC       X(25)     VALUE
  14884. 027800         "ECOLOGICAL SITE INVENTORY".
  14885. 027900     03  FILLER                  PIC       X(35)     VALUE SPACES.
  14886. 028000     03  FILLER                  PIC       X(18)     VALUE
  14887. 028100         "PROGRAM:  ES315P  ".
  14888. 028200 01  HDR-3.
  14889. 028300     03  FILLER                  PIC       X(08)     VALUE
  14890. 028400         "   DI:  ".
  14891. 028500     03  HDR-DIST-CD             PIC       X(02).
  14892. 028600     03  FILLER                  PIC       X(04)     VALUE SPACES.
  14893. 028700     03  HDR-DIST-NM             PIC       X(25).
  14894. 028800     03  FILER                   PIC       X(79)     VALUE SPACES.
  14895. 028900     03  FILLER                  PIC       X(14)     VALUE
  14896. 029000         "PCN:  PCN315  ".
  14897. 029100 01  HDR-4.
  14898. 029200     03  FILLER                  PIC       X(08)     VALUE
  14899. 029300         "  INV:  ".
  14900. 029400     03  HDR-INV-CD              PIC       X(04).
  14901. 029500     03  FILLER                  PIC       X(02)     VALUE SPACES.
  14902. 029600     03  HDR-INV-NM              PIC       X(25).
  14903. 029700     03  FILLER                  PIC       X(16)     VALUE SPACES.
  14904. 029800     03  HDR-REC-TYPE            PIC       X(02).
  14905. 029900     03  FILLER                  PIC       X(18)     VALUE
  14906. 030000         " VERIFICATION LIST".
  14907. 030100     03  FILLER                  PIC       X(57)     VALUE SPACES.
  14908. 030200 01  HDR-5-VB.
  14909. 030300     03  FILLER                  PIC       X(16)     VALUE
  14910. 030400         "(1-2)        (3)".
  14911. 030500     03  FILLER                  PIC       X(13)     VALUE SPACES.
  14912. 030600     03  FILLER                  PIC       X(38)     VALUE
  14913. 030700         "(4)      (5) (6)         (7)  (8)  (9)".
  14914. 030800     03  FILLER                  PIC       X(53)     VALUE
  14915. 030900         "     (10)     (11)  (12)  (13)   (14) (15) (16)  (17)".
  14916. 031000     03  FILLER                  PIC       X(12)     VALUE
  14917. 031100         "  (18)  (19)".
  14918. 031200 01  HDR-6-VB.
  14919. 031300     03  FILLER                  PIC       X(51)     VALUE
  14920. 031400         " REC  ADMINISTRATIVE UNIT   CLMTC    DATE ACT  LINE".
  14921. 031500     03  FILLER                  PIC       X(25)     VALUE
  14922. 031600         "   SWA  TRN  PCT    RANGE".
  14923. 031700     03  FILLER                  PIC       X(24)     VALUE SPACES.
  14924. 031800     03  FILLER                  PIC       X(32)     VALUE
  14925. 031900         "VEG  COND  PCT        LAND  SOIL".
  14926. 032000 01  HDR-7-VB.
  14927. 032100     03  FILLER                  PIC       X(51)     VALUE
  14928. 032200         "TYPE  ST   DI   RA   PU   ADJFCTR  YYMMDD  CD   NUM".
  14929. 032300     03  FILLER                  PIC       X(58)     VALUE
  14930. 032400     "   NUM  NUM  SWA    SITE     STRAT ALLOT  PAST SUBTYP  CL ".
  14931. 032500     03  FILLER                  PIC       X(23)     VALUE
  14932. 032600         "SLOPE SLOPE  FORM   SER".
  14933. 032700 01  HDR-8-VB.
  14934. 032800     03  FILLER                  PIC       X(52)     VALUE
  14935. 032900         " 1-4  5-6  7-8 9-10 11-12   13-17   18-23  24 25-28 ".
  14936. 033000     03  FILLER                  PIC       X(52)     VALUE
  14937. 033100         "29-32 33-4 35-7    38-48    49-52 53-56 57-58  59-62".
  14938. 033200     03  FILLER                  PIC       X(26)     VALUE
  14939. 033300         "63 64-66 67-68 69-71 72-76".
  14940. 033400 01  HDR-9-VB.
  14941. 033500     03  FILLER                  PIC       X(53)     VALUE
  14942. 033600         "XXXX  XX   XX   XX   XX    99.999  XXXXXX  X   9999  ".
  14943. 033700     03  FILLER                  PIC       X(53)     VALUE
  14944. 033800         "XXXX   XX  999 XXXXXXXXXXX  9999  9999   99    9999  ".
  14945. 033900     03  FILLER                  PIC       X(26)     VALUE
  14946. 034000         "X   999    XX   XXX  XXXXX".
  14947. 034100 01  HDR-10-DET-VB.
  14948. 034200     03  REC-TYPE-3529-VB-P1     PIC       X(02).
  14949. 034300     03  FMT-NO-3576-VB-P1       PIC       X(01).
  14950. 034400     03  FMT-CD-3579-VB-P1       PIC       X(01).
  14951. 034500     03  FILLER                  PIC       X(02)     VALUE SPACES.
  14952. 034600     03  ADM-ST-0003-VB-P1       PIC       X(02).
  14953. 034700     03  FILLER                  PIC       X(03)     VALUE SPACES.
  14954. 034800     03  ADM-DI-0003-VB-P1       PIC       X(02).
  14955. 034900     03  FILLER                  PIC       X(03)     VALUE SPACES.
  14956. 035000     03  ADM-RA-0003-VB-P1       PIC       X(02).
  14957. 035100     03  FILLER                  PIC       X(03)     VALUE SPACES.
  14958. 035200     03  ADM-PU-0003-VB-P1       PIC       X(02).
  14959. 035300     03  FILLER                  PIC       X(04)     VALUE SPACES.
  14960. 035400     03  CLMTC-ADJ-FCTR-3547-VB-P1  PIC    99.999.
  14961. 035500     03  FILLER                  PIC       X(02)     VALUE SPACES.
  14962. 035600     03  DATA-DT-6618-VB-P1      PIC       X(06).
  14963. 035700     03  FILLER                  PIC       X(02)     VALUE SPACES.
  14964. 035800     03  ACT-CD-7350-VB-P1       PIC       X(01).
  14965. 035900     03  FILLER                  PIC       X(03)     VALUE SPACES.
  14966. 036000     03  LINE-NO-3578-VB-P1      PIC       X(04).
  14967. 036100     03  FILLER                  PIC       X(02)     VALUE SPACES.
  14968. 036200     03  SWA-3507-VB-P1          PIC       X(04).
  14969. 036300     03  FILLER                  PIC       X(03)     VALUE SPACES.
  14970. 036400     03  TRN-NUM-3508-VB-P1      PIC       X(02).
  14971. 036500     03  FILLER                  PIC       X(02)     VALUE SPACES.
  14972. 036600     03  SWA-PCT-3516-VB-P1      PIC       X(03).
  14973. 036700     03  FILLER                  PIC       X(01)     VALUE SPACE.
  14974. 036800     03  RNG-SITE-ID-3528-VB-P1  PIC       X(11).
  14975. 036900     03  FILLER                  PIC       X(02)     VALUE SPACES.
  14976. 037000     03  STRATUM-NUM-3906-VB-P1  PIC       X(04).
  14977. 037100     03  FILLER                  PIC       X(02)     VALUE SPACES.
  14978. 037200     03  ALLOT-NUM-0968-VB-P1    PIC       9(04).
  14979. 037300     03  FILLER                  PIC       X(03)     VALUE SPACES.
  14980. 037400     03  PASTURE-NUM-3905-VB-P1  PIC       9(02).
  14981. 037500     03  FILLER                  PIC       X(04)     VALUE SPACES.
  14982. 037600     03  VEG-SUB-TYPE-2706-VB-P1  PIC      X(04).
  14983. 037700     03  FILLER                  PIC       X(02)     VALUE SPACES.
  14984. 037800     03  RNG-ECOL-COND-CLS-2625-VB-P1  PIC X(01).
  14985. 037900     03  FILLER                  PIC       X(03)     VALUE SPACES.
  14986. 038000     03  PCT-SLP-3874-VB-P1      PIC       X(03).
  14987. 038100     03  FILLER                  PIC       X(04)     VALUE SPACES.
  14988. 038200     03  ASPT-6523-VB-P1         PIC       X(02).
  14989. 038300     03  FILLER                  PIC       X(03)     VALUE SPACES.
  14990. 038400     03  L-FORM-5132-VB-P1       PIC       X(03).
  14991. 038500     03  FILLER                  PIC       X(02)     VALUE SPACES.
  14992. 038600     03  SOIL-PHAS-4649-VB-P1    PIC       X(05).
  14993. 038700 01  HDR-5-VR1.
  14994. 038800     03  FILLER                  PIC       X(52)     VALUE
  14995. 038900         "(1-2)   (3)        (4)     (5)        (6)           ".
  14996. 039000     03  FILLER                  PIC       X(49)     VALUE
  14997. 039100         "(7)            (8)        (9)                (10)".
  14998. 039200     03  FILLER                  PIC       X(31)     VALUE SPACES.
  14999. 039300 01  HDR-6-VR1.
  15000. 039400     03  FILLER                  PIC       X(51)     VALUE
  15001. 039500         " REC    ADMIN     DATE     ACT     RANGE SITE      ".
  15002. 039600     03  FILLER                  PIC       X(22)     VALUE
  15003. 039700         "RANGE      PRECIP ZONE".
  15004. 039800     03  FILLER                  PIC       X(15)     VALUE SPACES.
  15005. 039900     03  FILLER                  PIC       X(20)     VALUE
  15006. 040000         "LBS OF PROD PER ACRE".
  15007. 040100     03  FILLER                  PIC       X(24)     VALUE SPACES.
  15008. 040200 01  HDR-7-VR1.
  15009. 040300     03  FILLER                  PIC       X(43)     VALUE
  15010. 040400         "TYPE      ST     YYMMDD     CD       NUMBER".
  15011. 040500     03  FILLER                  PIC       X(51)     VALUE
  15012. 040600         "      SITE NAME    LOW      HI     SSF    AVG YR   ".
  15013. 040700     03  FILLER                  PIC       X(24)     VALUE
  15014. 040800         "   FVRBL YR   UNFVRBL YR".
  15015. 040900     03  FILLER                  PIC       X(17)     VALUE SPACES.
  15016. 041000 01  HDR-8-VR1.
  15017. 041100     03  FILLER                  PIC       X(42)     VALUE
  15018. 041200         " 1-4     5-6      13-18     19       20-30".
  15019. 041300     03  FILLER                  PIC       X(48)     VALUE
  15020. 041400         "         35-42      43-4   45-6    47-9    50-55".
  15021. 041500     03  FILLER                  PIC       X(22)     VALUE
  15022. 041600         "      56-61      62-67".
  15023. 041700     03  FILLER                  PIC       X(20)     VALUE SPACES.
  15024. 041800 01  HDR-9-VR1.
  15025. 041900     03  FILLER                  PIC       X(49)     VALUE
  15026. 042000         "XXXX      XX     XXXXXX     X     XXXXXXXXXXX    ".
  15027. 042100         03  FILLER              PIC       X(46)     VALUE
  15028. 042200         "XXXXXXXX      99      99     999    999999    ".
  15029. 042300     03  FILLER                  PIC       X(18)     VALUE
  15030. 042400         "999999      999999".
  15031. 042500     03  FILLER                  PIC       X(19)     VALUE SPACES.
  15032. 042600 01  HDR-10-DET-VR1.
  15033. 042700     03  REC-TYPE-3529-VR1-P1    PIC       X(02).
  15034. 042800     03  FMT-NO-3576-VR1-P1      PIC       X(01).
  15035. 042900     03  FMT-CD-3579-VR1-P1      PIC       X(01).
  15036. 043000     03  FILLER                  PIC       X(06)     VALUE SPACES.
  15037. 043100     03  ADM-ST-0003-VR1-P1      PIC       X(02).
  15038. 043200     03  FILLER                  PIC       X(05)     VALUE SPACES.
  15039. 043300     03  DATA-DT-6618-VR1-P1     PIC       X(06).
  15040. 043400     03  FILLER                  PIC       X(05)     VALUE SPACES.
  15041. 043500     03  ACT-CD-7350-VR1-P1      PIC       X(01).
  15042. 043600     03  FILLER                  PIC       X(05)     VALUE SPACES.
  15043. 043700     03  RNG-SITE-ID-3528-VR1-P1 PIC       X(11).
  15044. 043800     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15045. 043900     03  RNG-SITE-NAM-3914-VR1-P1 PIC      X(08).
  15046. 044000     03  FILLER                  PIC       X(06)     VALUE SPACES.
  15047. 044100     03  PRECIP-ZONE-LOW-3909-VR1-P1  PIC  X(02).
  15048. 044200     03  FILLER                  PIC       X(06)     VALUE SPACES.
  15049. 044300     03  PRECIP-ZONE-HI-3909-VR1-P1  PIC  X(02).
  15050. 044400     03  FILLER                  PIC       X(05)     VALUE SPACES.
  15051. 044500     03  SSF-VAL-AVG-4818-VR1-P1 PIC       X(03).
  15052. 044600     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15053. 044700     03  POTN-PPA1-3930-VR1-P1   PIC       X(06).
  15054. 044800     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15055. 044900     03  POTN-PPA2-3930-VR1-P1   PIC       X(06).
  15056. 045000     03  FILLER                  PIC       X(06)     VALUE SPACES.
  15057. 045100     03  POTN-PPA3-3930-VR1-P1   PIC       X(06).
  15058. 045200     03  FILLER                  PIC       X(19)     VALUE SPACES.
  15059. 045300 01  HDR-5-VR2.
  15060. 045400     03  FILLER                  PIC       X(41)     VALUE
  15061. 045500         "(1-2)   (3)        (4)     (5)        (6)".
  15062. 045600     03  FILLER                  PIC       X(16)     VALUE SPACES.
  15063. 045700     03  FILLER                  PIC       X(54)     VALUE
  15064. 045800         "(11)    (12)      (11)    (12)      (11)    (12)      ".
  15065. 045900     03  FILLER                  PIC       X(21)     VALUE
  15066. 046000         "(11)    (12)         ".
  15067. 046100 01  HDR-6-VR2.
  15068. 046200     03  FILLER                  PIC       X(51)     VALUE
  15069. 046300         " REC    ADMIN     DATE     ACT     RANGE SITE  LINE".
  15070. 046400     03  FILLER                  PIC       X(46)     VALUE
  15071. 046500         "     PLANT     PCT     PLANT     PCT     PLANT".
  15072. 046600     03  FILLER                  PIC       X(35)     VALUE
  15073. 046700         "     PCT     PLANT     PCT         ".
  15074. 046800 01  HDR-7-VR2.
  15075. 046900     03  FILLER                  PIC       X(48)     VALUE
  15076. 047000         "TYPE      ST     YYMMDD     CD       NUMBER     ".
  15077. 047100     03  FILLER                  PIC       X(54)     VALUE
  15078. 047200         "NUM     SYMBOL    COMP    SYMBOL    COMP    SYMBOL    ".
  15079. 047300     03  FILLER                  PIC       X(22)     VALUE
  15080. 047400         "COMP    SYMBOL    COMP".
  15081. 047500     03  FILLER                  PIC       X(8)      VALUE SPACES.
  15082. 047600 01  HDR-8-VR2.
  15083. 047700     03  FILLER                  PIC       X(47)     VALUE
  15084. 047800         " 1-4     5-6      13-18     19       20-30     ".
  15085. 047900     03  FILLER                  PIC       X(50)     VALUE
  15086. 048000         "31-34    35-41    42-44    45-51    52-44    55-61".
  15087. 048100     03  FILLER                  PIC       X(35)     VALUE
  15088. 048200         "    62-64    65-71    72-74        ".
  15089. 048300 01  HDR-9-VR2.
  15090. 048400     03  FILLER                  PIC       X(51)     VALUE
  15091. 048500         "XXXX      XX     XXXXXX     X     XXXXXXXXXXX  9999".
  15092. 048600     03  FILLER                  PIC       X(40)     VALUE
  15093. 048700         "    XXXXXXX    999    XXXXXXX    999    ".
  15094. 048800     03  FILLER                  PIC       X(32)     VALUE
  15095. 048900         "XXXXXXX    999    XXXXXXX    999".
  15096. 049000     03  FILLER                  PIC       X(9)      VALUE SPACES.
  15097. 049100 01  HDR-10-DET-VR2.
  15098. 049200     03  REC-TYPE-3529-VR2-P1    PIC       X(02).
  15099. 049300     03  FMT-NO-3576-VR2-P1      PIC       X(01).
  15100. 049400     03  FMT-CD-3579-VR2-P1      PIC       X(01).
  15101. 049500     03  FILLER                  PIC       X(06)     VALUE SPACES.
  15102. 049600     03  ADM-ST-0003-VR2-P1      PIC       X(02).
  15103. 049700     03  FILLER                  PIC       X(05)     VALUE SPACES.
  15104. 049800     03  DATA-DT-6618-VR2-P1     PIC       X(06).
  15105. 049900     03  FILLER                  PIC       X(05)     VALUE SPACES.
  15106. 050000     03  ACT-CD-7350-VR2-P1      PIC       X(01).
  15107. 050100     03  FILLER                  PIC       X(05)     VALUE SPACES.
  15108. 050200     03  RNG-SITE-ID-3528-VR2-P1 PIC       X(11).
  15109. 050300     03  FILLER                  PIC       X(02)     VALUE SPACES.
  15110. 050400     03  LINE-NO-3578-VR2-P1     PIC       X(04).
  15111. 050500     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15112. 050600     03  PLANT-CD1-2646-VR2-P1   PIC       X(07).
  15113. 050700     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15114. 050800     03  POTN-PCT1-3535-VR2-P1   PIC       X(03).
  15115. 050900     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15116. 051000     03  PLANT-CD2-2646-VR2-P1   PIC       X(07).
  15117. 051100     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15118. 051200     03  POTN-PCT2-3535-VR2-P1   PIC       X(03).
  15119. 051300     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15120. 051400     03  PLANT-CD3-2646-VR2-P1   PIC       X(07).
  15121. 051500     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15122. 051600     03  POTN-PCT3-3535-VR2-P1   PIC       X(03).
  15123. 051700     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15124. 051800     03  PLANT-CD4-2646-VR2-P1   PIC       X(07).
  15125. 051900     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15126. 052000     03  POTN-PCT4-3535-VR2-P1   PIC       X(03).
  15127. 052100     03  FILLER                  PIC       X(09)     VALUE SPACES.
  15128. 052200 01  HDR-5-VR3.
  15129. 052300     03  FILLER                  PIC       X(41)     VALUE
  15130. 052400         "(1-2)   (3)        (4)     (5)        (6)".
  15131. 052500     03  FILLER                  PIC       X(16)     VALUE SPACES.
  15132. 052600     03  FILLER                  PIC       X(04)     VALUE "(13)".
  15133. 052700     03  FILLER                  PIC       X(18)     VALUE SPACES.
  15134. 052800     03  FILLER                  PIC       X(04)     VALUE "(14)".
  15135. 052900     03  FILLER                  PIC       X(14)     VALUE SPACES.
  15136. 053000     03  FILLER                  PIC       X(04)     VALUE "(13)".
  15137. 053100     03  FILLER                  PIC       X(17)     VALUE SPACES.
  15138. 053200     03  FILLER                  PIC       X(04)     VALUE "(14)".
  15139. 053300     03  FILLER                  PIC       X(10)     VALUE SPACES.
  15140. 053400 01  HDR-6-VR3.
  15141. 053500     03  FILLER                  PIC       X(50)     VALUE
  15142. 053600         "REC    ADMIN     DATE     ACT     RANGE SITE  LINE".
  15143. 053700     03  FILLER                  PIC       X(13)     VALUE
  15144. 053800         "     PHASE OF".
  15145. 053900     03  FILLER                  PIC       X(32)     VALUE SPACES.
  15146. 054000     03  FILLER                  PIC       X(13)     VALUE
  15147. 054100         "     PHASE OF".
  15148. 054200     03  FILLER                  PIC       X(28)     VALUE SPACES.
  15149. 054300 01  HDR-7-VR3.
  15150. 054400     03  FILLER                  PIC       X(48)     VALUE
  15151. 054500         "TYPE      ST     YYMMDD     CD       NUMBER     ".
  15152. 054600     03  FILLER                  PIC       X(38)     VALUE
  15153. 054700         "NUM    SOIL SERIES           SOIL NAME".
  15154. 054800     03  FILLER                  PIC       X(46)     VALUE
  15155. 054900         "         SOIL SERIES          SOIL NAME       ".
  15156. 055000 01  HDR-8-VR3.
  15157. 055100     03  FILLER                  PIC       X(52)     VALUE
  15158. 055200         " 1-4     5-6      13-18     19       20-30     31-34".
  15159. 055300     03  FILLER                  PIC       X(50)     VALUE
  15160. 055400         "     35-39                 40-63             64-68".
  15161. 055500     03  FILLER                  PIC       X(30)     VALUE
  15162. 055600         "                69-92         ".
  15163. 055700 01  HDR-9-VR3.
  15164. 055800     03  FILLER                  PIC       X(47)     VALUE
  15165. 055900         "XXXX      XX     XXXXXX     X     XXXXXXXXXXX  ".
  15166. 056000     03  FILLER                  PIC       X(46)     VALUE
  15167. 056100         "9999      XXXXX       XXXXXXXXXXXXXXXXXXXXXXXX".
  15168. 056200     03  FILLER                  PIC       X(39)     VALUE
  15169. 056300         "    XXXXX      XXXXXXXXXXXXXXXXXXXXXXXX".
  15170. 056400 01  HDR-10-DET-VR3.
  15171. 056500     03  REC-TYPE-3529-VR3-P1    PIC       X(02).
  15172. 056600     03  FMT-NO-3576-VR3-P1      PIC       X(01).
  15173. 056700     03  FMT-CD-3579-VR3-P1      PIC       X(01).
  15174. 056800     03  FILLER                  PIC       X(06)     VALUE SPACES.
  15175. 056900     03  ADM-ST-0003-VR3-P1      PIC       X(02).
  15176. 057000     03  FILLER                  PIC       X(05)     VALUE SPACES.
  15177. 057100     03  DATA-DT-6618-VR3-P1     PIC       X(06).
  15178. 057200     03  FILLER                  PIC       X(05)     VALUE SPACES.
  15179. 057300     03  ACT-CD-7350-VR3-P1      PIC       X(01).
  15180. 057400     03  FILLER                  PIC       X(05)     VALUE SPACES.
  15181. 057500     03  RNG-SITE-ID-3528-VR3-P1 PIC       X(11).
  15182. 057600     03  FILLER                  PIC       X(02)     VALUE SPACES.
  15183. 057700     03  LINE-NO-3578-VR3-P1     PIC       X(04).
  15184. 057800     03  FILLER                  PIC       X(06)     VALUE SPACES.
  15185. 057900     03  SOIL-PHAS1-4649-VR3-P1  PIC       X(05).
  15186. 058000     03  FILLER                  PIC       X(07)     VALUE SPACES.
  15187. 058100     03  SOIL-NAM1-4648-VR3-P1   PIC       X(24).
  15188. 058200     03  FILLER                  PIC       X(04)     VALUE SPACES.
  15189. 058300     03  SOIL-PHAS2-4649-VR3-P1  PIC       X(05).
  15190. 058400     03  FILLER                  PIC       X(06)     VALUE SPACES.
  15191. 058500     03  SOIL-NAM2-4648-VR3-P1   PIC       X(24).
  15192. 058600 PROCEDURE DIVISION.
  15193. 058700 START-SORT SECTION.
  15194. 058800 100-SORT.
  15195. 058900     SORT  SORT-FILE ON ASCENDING SORT-KEY1-VB
  15196. 059000     INPUT PROCEDURE PRE-SORT
  15197. 059100     OUTPUT PROCEDURE POST-SORT.
  15198. 059200 200-END-SECTION.
  15199. 059300     FINISH DIC-DE.
  15200. 059400     DISPLAY "VB-CNT  " VB-CNT.
  15201. 059500     DISPLAY "VR1-CNT  "  VR1-CNT.
  15202. 059600     DISPLAY "VR2-CNT  "  VR2-CNT.
  15203. 059700     DISPLAY "VR3-CNT  "  VR3-CNT.
  15204. 059800     CLOSE PRINT-FILE.
  15205. 059900     STOP RUN.
  15206. 060000 PRE-SORT SECTION.
  15207. 060100 300-HSKPNG.
  15208. 060200     OPEN INPUT INPUT-FILE1.
  15209. 060300     MOVE SPACES TO S-KEY1  S-KEY2  S-KEY3  S-KEY4.
  15210. 060400 400-MAIN.
  15211. 060500     PERFORM  500-RD-FILE1 THRU 600-EXIT-RD-FL1 UNTIL EOF.
  15212. 060600     CLOSE INPUT-FILE1.
  15213. 060700     GO TO 960-EXIT-VR3.
  15214. 060800 500-RD-FILE1.
  15215. 060900     READ INPUT-FILE1  AT END MOVE 1 TO EOF-SWITCH.
  15216. 061000     IF  (EOF-SWITCH = 1) GO TO 600-EXIT-RD-FL1.
  15217. 061100     ADD 1 TO INPUT1-CNT.
  15218. 061200     IF  REC-TYPE-3529-VB-I1 = "VB"
  15219. 061300         PERFORM 700-MV-VB-TO-SRT THRU 750-EXIT-VB
  15220. 061400         GO  TO 600-EXIT-RD-FL1.
  15221. 061500     IF  REC-TYPE-3529-VB-I1 = "VR"  AND FMT-NO-3576-VB-I1 = "1"
  15222. 061600         PERFORM 900-MV-VR1-TO-SRT THRU 920-EXIT-VR1
  15223. 061700         GO  TO 600-EXIT-RD-FL1.
  15224. 061800     IF  REC-TYPE-3529-VR2-I1 = "VR" AND FMT-NO-3576-VR1-I1 = "2"
  15225. 061900         PERFORM 930-MV-VR2-TO-SRT THRU 940-EXIT-VR2
  15226. 062000         GO  TO 600-EXIT-RD-FL1.
  15227. 062100     IF  REC-TYPE-3529-VR3-I1 = "VR" AND FMT-NO-3576-VR1-I1 = "3"
  15228. 062200         PERFORM 950-MV-VR3-TO-SRT THRU 960-EXIT-VR3
  15229. 062300         GO  TO 600-EXIT-RD-FL1.
  15230. 062400 600-EXIT-RD-FL1.
  15231. 062500     EXIT.
  15232. 062600 700-MV-VB-TO-SRT.
  15233. 062700     ADD 1 TO VB-CNT.
  15234. 062800     MOVE REC-TYPE-3529-VB-I1    TO  REC-TYPE-3529-VB-S1.
  15235. 062900     MOVE FMT-NO-3576-VB-I1      TO  FMT-NO-3576-VB-S1.
  15236. 063000     MOVE FMT-CD-3579-VB-I1      TO  FMT-CD-3579-VB-S1.
  15237. 063100     MOVE ADM-UNIT-0003-VB-I1     TO  ADM-UNIT-0003-VB-S1.
  15238. 063200     MOVE CLMTC-ADJ-FCTR-3547-VB-I1  TO CLMTC-ADJ-FCTR-3547-VB-S1.
  15239. 063300     MOVE DATA-DT-6618-VB-I1     TO  DATA-DT-6618-VB-S1.
  15240. 063400     MOVE ACT-CD-7350-VB-I1      TO  ACT-CD-7350-VB-S1.
  15241. 063500     MOVE LINE-NO-3578-VB-I1     TO  LINE-NO-3578-VB-S1.
  15242. 063600     MOVE SWA-3507-VB-I1         TO  SWA-3507-VB-S1.
  15243. 063700     MOVE ALLOT-NUM-0968-VB-I1   TO  ALLOT-NUM-0968-VB-S1.
  15244. 063800     MOVE PASTURE-NUM-3905-VB-I1  TO  PASTURE-NUM-3905-VB-S1.
  15245. 063900     MOVE SWA-PCT-3516-VB-I1      TO  SWA-PCT-3516-VB-S1.
  15246. 064000     MOVE RNG-SITE-ID-3528-VB-I1  TO  RNG-SITE-ID-3528-VB-S1.
  15247. 064100     MOVE VEG-SUB-TYPE-2706-VB-I1 TO  VEG-SUB-TYPE-2706-VB-S1.
  15248. 064200     MOVE RNG-ECOL-COND-CLS-2625-VB-I1  TO
  15249. 064300         RNG-ECOL-COND-CLS-2625-VB-S1.
  15250. 064400     MOVE PCT-SLP-3874-VB-I1       TO  PCT-SLP-3874-VB-S1.
  15251. 064500     MOVE ASPT-6523-VB-I1          TO  ASPT-6523-VB-S1.
  15252. 064600     MOVE L-FORM-5132-VB-I1        TO  L-FORM-5132-VB-S1.
  15253. 064700     MOVE SOIL-PHAS-4649-VB-I1     TO  SOIL-PHAS-4649-VB-S1.
  15254. 064800     MOVE TRN-NUM-3508-VB-I1     TO  TRN-NUM-3508-VB-S1.
  15255. 064900     MOVE STRATUM-NUM-3906-VB-I1 TO  STRATUM-NUM-3906-VB-S1.
  15256. 065000     MOVE CLMTC-ADJ-FCTR-3547-VB-I1  TO CLMTC-ADJ-FCTR-3547-VB-S1.
  15257. 065100     RELEASE S-KEY1.
  15258. 065200 750-EXIT-VB.
  15259. 065300     EXIT.
  15260. 065400 900-MV-VR1-TO-SRT.
  15261. 065500     ADD 1 TO VR1-CNT.
  15262. 065600     MOVE REC-TYPE-3529-VR1-I1   TO  REC-TYPE-3529-VR1-S1.
  15263. 065700     MOVE FMT-NO-3576-VR1-I1     TO  FMT-NO-3576-VR1-S1.
  15264. 065800     MOVE FMT-CD-3579-VR1-I1     TO  FMT-CD-3579-VR1-S1.
  15265. 065900     MOVE ADM-ST-0003-VR1-I1     TO  ADM-ST-0003-VR1-S1.
  15266. 066000     MOVE DATA-DT-6618-VR1-I1    TO  DATA-DT-6618-VR1-S1.
  15267. 066100     MOVE ACT-CD-7350-VR1-I1     TO  ACT-CD-7350-VR1-S1.
  15268. 066200     MOVE RNG-SITE-ID-3528-VR1-I1  TO  RNG-SITE-ID-3528-VR1-S1.
  15269. 066300     MOVE RNG-SITE-NAM-3914-VR1-I1 TO  RNG-SITE-NAM-3914-VR1-S1.
  15270. 066400     MOVE PRECIP-ZONE-3909-VR1-I1  TO  PRECIP-ZONE-3909-VR1-S1.
  15271. 066500     MOVE SSF-VAL-AVG-4818-VR1-I1  TO  SSF-VAL-AVG-4818-VR1-S1.
  15272. 066600     MOVE POTN-PPA-3930-VR1-I1(1)  TO  POTN-PPA-3930-VR1-S1(1).
  15273. 066700     MOVE POTN-PPA-3930-VR1-I1(2)  TO  POTN-PPA-3930-VR1-S1(2).
  15274. 066800     MOVE POTN-PPA-3930-VR1-I1(3)  TO  POTN-PPA-3930-VR1-S1(3).
  15275. 066900     RELEASE S-KEY2.
  15276. 067000 920-EXIT-VR1.
  15277. 067100     EXIT.
  15278. 067200 930-MV-VR2-TO-SRT.
  15279. 067300     ADD 1 TO VR2-CNT.
  15280. 067400     MOVE REC-TYPE-3529-VR2-I1   TO  REC-TYPE-3529-VR2-S1.
  15281. 067500     MOVE FMT-NO-3576-VR2-I1     TO  FMT-NO-3576-VR2-S1.
  15282. 067600     MOVE FMT-CD-3579-VR2-I1     TO  FMT-CD-3579-VR2-S1.
  15283. 067700     MOVE ADM-ST-0003-VR2-I1   TO  ADM-ST-0003-VR2-S1.
  15284. 067800     MOVE  DATA-DT-6618-VR2-I1   TO  DATA-DT-6618-VR2-S1.
  15285. 067900     MOVE  ACT-CD-7350-VR2-I1    TO  ACT-CD-7350-VR2-S1.
  15286. 068000     MOVE RNG-SITE-ID-3528-VR2-I1  TO  RNG-SITE-ID-3528-VR2-S1.
  15287. 068100     MOVE LINE-NO-3578-VR2-I1    TO  LINE-NO-3578-VR2-S1.
  15288. 068200     MOVE PLANT-CD-POTN-PCT-VR2-I1(1) TO
  15289. 068300         PLANT-CD-POTN-PCT-VR2-S1(1).
  15290. 068400     MOVE PLANT-CD-POTN-PCT-VR2-I1(2)  TO
  15291. 068500          PLANT-CD-POTN-PCT-VR2-S1(2).
  15292. 068600     MOVE PLANT-CD-POTN-PCT-VR2-I1(3) TO
  15293. 068700         PLANT-CD-POTN-PCT-VR2-S1(3).
  15294. 068800     MOVE PLANT-CD-POTN-PCT-VR2-I1(4) TO
  15295. 068900         PLANT-CD-POTN-PCT-VR2-S1(4).
  15296. 069000     RELEASE S-KEY3.
  15297. 069100 940-EXIT-VR2.
  15298. 069200     EXIT.
  15299. 069300 950-MV-VR3-TO-SRT.
  15300. 069400     ADD 1 TO VR3-CNT.
  15301. 069500     MOVE REC-TYPE-3529-VR3-I1   TO  REC-TYPE-3529-VR3-S1.
  15302. 069600     MOVE FMT-NO-3576-VR3-I1     TO  FMT-NO-3576-VR3-S1.
  15303. 069700     MOVE FMT-CD-3579-VR3-I1     TO  FMT-CD-3579-VR3-S1.
  15304. 069800     MOVE ADM-ST-0003-VR3-I1     TO  ADM-ST-0003-VR3-S1.
  15305. 069900     MOVE DATA-DT-6618-VR3-I1  TO  DATA-DT-6618-VR3-S1.
  15306. 070000     MOVE ACT-CD-7350-VR3-I1   TO  ACT-CD-7350-VR3-S1.
  15307. 070100     MOVE RNG-SITE-ID-3528-VR3-I1  TO  RNG-SITE-ID-3528-VR3-S1.
  15308. 070200     MOVE FMT-NO-3576-VR3-I1     TO  FMT-NO-3576-VR3-S1.
  15309. 070300     MOVE LINE-NO-3578-VR3-I1    TO  LINE-NO-3578-VR3-S1.
  15310. 070400     MOVE SOIL-PHASE-NAME-VR3-I1(1)  TO SOIL-PHASE-NAME-VR3-S1(1).
  15311. 070500     MOVE SOIL-PHASE-NAME-VR3-I1(2)  TO SOIL-PHASE-NAME-VR3-S1(2).
  15312. 070600     RELEASE S-KEY4.
  15313. 070700 960-EXIT-VR3.
  15314. 070800     EXIT.
  15315. 070900 POST-SORT SECTION.
  15316. 071000 3050-RET-HSKPNG.
  15317. 071100     OPEN OUTPUT PRINT-FILE.
  15318. 071200     ACCEPT  PARAMETER.
  15319. 071300     ACCEPT  HOLD-DT FROM DATE.
  15320. 071400     MOVE YR-DT TO HDR-YR.
  15321. 071500     MOVE MON(MO-DT) TO HDR-MO.
  15322. 071600     MOVE DY-DT TO HDR-DA.
  15323. 071700     READY DIC-DE.
  15324. 071800     PERFORM 4000-VALIDATE-INV THRU 4050-EXIT-STDI.
  15325. 071900 3060-RET.
  15326. 072000     RETURN  SORT-FILE AT END MOVE 1 TO EOR-SWITCH.
  15327. 072100     IF REC-TYPE-3529-VB-S1 = "VB"
  15328. 072200          MOVE 1 TO VB-SW.
  15329. 072300     PERFORM 4460-CHK-WH-REC THRU 4470-EXIT-WH-REC.
  15330. 072400     PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
  15331. 072500 3070-MAIN-DRIVER.
  15332. 072600     MOVE 1 TO VB-SW.
  15333. 072700     PERFORM 4300-DET-REC-LINE THRU 4350-EXIT-DET UNTIL EOR.
  15334. 072800     GO TO 4830-DUMMY.
  15335. 072900 4000-VALIDATE-INV.
  15336. 073000     MOVE PARAMETER TO DE-CD-8822-DEC  HDR-INV-CD.
  15337. 073100     MOVE 3940 TO DE-NO-8801-DEC.
  15338. 073200     FIND ANY CODE-DEC.
  15339. 073300     MOVE DB-STATUS TO DB-STAT.
  15340. 073400     IF  NOT OK
  15341. 073500         MOVE "UNKNOWN" TO HDR-ST-NM HDR-DIST-NM HDR-INV-NM
  15342. 073600         GO  TO 4050-EXIT-STDI.
  15343. 073700     GET CODE-DEC.
  15344. 073800     MOVE DB-STATUS TO DB-STAT.
  15345. 073900     IF  NOT OK
  15346. 074000         DISPLAY "ES315PBD   DIDN'T GET INVN"
  15347. 074100         DISPLAY DB-STAT
  15348. 074200         GO  TO 4050-EXIT-STDI.
  15349. 074300     MOVE DE-CD-NAM-8823-DEC TO INV-HLD.
  15350. 074400     MOVE INV-NM TO HDR-INV-NM.
  15351. 074500 4005-VALIDATE-ST.
  15352. 074600     MOVE ST-CD-HLD TO DE-CD-8822-DEC  HDR-ST-CD.
  15353. 074700     MOVE 0003 TO DE-NO-8801-DEC.
  15354. 074800     FIND ANY CODE-DEC.
  15355. 074900     MOVE DB-STATUS TO DB-STAT.
  15356. 075000     IF NOT OK
  15357. 075100         MOVE "UNKNOWN" TO HDR-ST-NM
  15358. 075200         GO TO 4008-EXIT-ST.
  15359. 075300     GET CODE-DEC.
  15360. 075400     MOVE DB-STATUS TO DB-STAT.
  15361. 075500     IF NOT OK
  15362. 075600         DISPLAY "ES315PBD  3  DIDN'T GET ST"
  15363. 075700         DISPLAY "ES315PBD  4  " DB-STAT
  15364. 075800         GO TO 4008-EXIT-ST.
  15365. 075900     MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
  15366. 076000     MOVE ST-NM-HLD TO HDR-ST-NM.
  15367. 076100 4008-EXIT-ST.
  15368. 076200     EXIT.
  15369. 076300 4010-VALIDATE-STDI.
  15370. 076400     MOVE ST-DIST-CD TO DE-CD-8822-DEC.
  15371. 076500     MOVE DI-CD-HLD TO HDR-DIST-CD.
  15372. 076600     MOVE 0003 TO DE-NO-8801-DEC.
  15373. 076700     FIND ANY CODE-DEC.
  15374. 076800     MOVE DB-STATUS TO DB-STAT.
  15375. 076900     IF  NOT OK
  15376. 077000         MOVE "UNKNOWN" TO HDR-DIST-NM
  15377. 077100         GO  TO 4050-EXIT-STDI.
  15378. 077200     GET CODE-DEC.
  15379. 077300     MOVE DB-STATUS TO DB-STAT.
  15380. 077400     IF  NOT OK
  15381. 077500         DISPLAY "ES315PBD 5 DIDN'T GET STDI"
  15382. 077600         DISPLAY  "ES315PBD 6 " DB-STAT
  15383. 077700         GO  TO 4050-EXIT-STDI.
  15384. 077800     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  15385. 077900     MOVE DB-STATUS TO DB-STAT.
  15386. 078000     IF  NOT OK
  15387. 078100         MOVE "UNKNOWN" TO HDR-DIST-NM
  15388. 078200         GO  TO 4050-EXIT-STDI.
  15389. 078300     GET CODE-EXPL-DECE.
  15390. 078400     MOVE DB-STATUS TO DB-STAT.
  15391. 078500     IF  NOT OK
  15392. 078600         DISPLAY "ES315PBD  7 DIDN'T GET DIST"
  15393. 078700         DISPLAY  "ES315PBD 8  " DB-STAT
  15394. 078800         GO  TO 4050-EXIT-STDI.
  15395. 078900     MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD
  15396. 079000     MOVE DIST-NM-HLD TO HDR-DIST-NM.
  15397. 079100 4050-EXIT-STDI.
  15398. 079200     EXIT.
  15399. 079300 4100-CHK-LINE-CNT.
  15400. 079400     IF VB-SW = 0 GO TO 4150-EXIT-LINE-OVR50.
  15401. 079500     IF  LINE-CNT > 50  OR (HLD-REC-TYPE = "VR2D" OR "VR3D")
  15402. 079600         PERFORM 4200-PRT-HDNG THRU 4250-HDNG-EXIT
  15403. 079700         GO  TO 4150-EXIT-LINE-OVR50.
  15404. 079800 4150-EXIT-LINE-OVR50.
  15405. 079900     EXIT.
  15406. 080000 4200-PRT-HDNG.
  15407. 080100     IF (HLD-REC-TYPE = "VB1D" OR "VR1D")
  15408. 080200         PERFORM 4210-START-HDR THRU 4228-EXIT-HDR-VR2-3
  15409. 080300         GO TO 4230-PRT-SPACES.
  15410. 080400     IF (LINE-CNT > 50 AND SW2-3 = 1) OR
  15411. 080500         (LINE-CNT > 50)
  15412. 080600         MOVE 1 TO SW2-3
  15413. 080700         MOVE 1 TO SW-DET-VR2-3
  15414. 080800         PERFORM 4210-START-HDR THRU 4228-EXIT-HDR-VR2-3
  15415. 080900         GO TO 4230-PRT-SPACES.
  15416. 081000     IF (SW2-3 = 1)
  15417. 081100         MOVE 0 TO SW2-3
  15418. 081200         PERFORM 4222-CHK-VR THRU 4228-EXIT-HDR-VR2-3
  15419. 081300         MOVE 0 TO SW-DET-VR2-3
  15420. 081400         GO TO 4230-PRT-SPACES.
  15421. 081500     GO TO 4230-PRT-SPACES.
  15422. 081600 4210-START-HDR.
  15423. 081700     ADD 1 TO PAGE-CNT.
  15424. 081800     MOVE PAGE-CNT TO HDR-PG.
  15425. 081900     WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
  15426. 082000     WRITE PRT-REC FROM HDR-2 AFTER ADVANCING 1 LINES.
  15427. 082100     WRITE PRT-REC FROM HDR-3 AFTER ADVANCING 1 LINES.
  15428. 082200     MOVE 2 TO LINE-CNT.
  15429. 082300 4220-CHK-WHAT-REC.
  15430. 082400     IF  HLD-REC-TYPE = "VB1D"
  15431. 082500         MOVE "VB" TO HDR-REC-TYPE
  15432. 082600         WRITE PRT-REC FROM HDR-4  AFTER ADVANCING 1 LINES
  15433. 082700         WRITE PRT-REC FROM HDR-5-VB AFTER ADVANCING 2 LINES
  15434. 082800         WRITE PRT-REC FROM HDR-6-VB AFTER ADVANCING 1 LINES
  15435. 082900         WRITE PRT-REC FROM HDR-7-VB AFTER ADVANCING 1 LINES
  15436. 083000         WRITE PRT-REC FROM HDR-8-VB AFTER ADVANCING 1 LINES
  15437. 083100         WRITE PRT-REC FROM HDR-9-VB AFTER ADVANCING 1 LINES
  15438. 083200         ADD 7 TO LINE-CNT
  15439. 083300         GO TO 4228-EXIT-HDR-VR2-3.
  15440. 083400 4222-CHK-VR.
  15441. 083500     IF (REC-TYPE-HLD = "VR" AND SW2-3 = 1)
  15442. 083600         MOVE "VR" TO HDR-REC-TYPE
  15443. 083700         WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
  15444. 083800         ADD 1 TO LINE-CNT.
  15445. 083900         IF SW-DET-VR2-3 = 1 NEXT SENTENCE
  15446. 084000         ELSE GO TO 4228-EXIT-HDR-VR2-3.
  15447. 084100     IF  HLD-REC-TYPE = "VR1D"
  15448. 084200         WRITE PRT-REC FROM HDR-5-VR1 AFTER ADVANCING 2 LINES
  15449. 084300         WRITE PRT-REC FROM HDR-6-VR1 AFTER ADVANCING 1 LINES
  15450. 084400         WRITE PRT-REC FROM HDR-7-VR1 AFTER ADVANCING 1 LINES
  15451. 084500         WRITE PRT-REC FROM HDR-8-VR1 AFTER ADVANCING 1 LINES
  15452. 084600         WRITE PRT-REC FROM HDR-9-VR1 AFTER ADVANCING 1 LINES
  15453. 084700         ADD 6 TO LINE-CNT
  15454. 084800         GO TO 4228-EXIT-HDR-VR2-3.
  15455. 084900 4225-CHK-VR2-3.
  15456. 085000     IF HLD-REC-TYPE = "VR2D"
  15457. 085100         WRITE PRT-REC FROM HDR-5-VR2 AFTER ADVANCING 2 LINES
  15458. 085200         WRITE PRT-REC FROM HDR-6-VR2 AFTER ADVANCING 1 LINES
  15459. 085300         WRITE PRT-REC FROM HDR-7-VR2 AFTER ADVANCING 1 LINES
  15460. 085400         WRITE PRT-REC FROM HDR-8-VR2 AFTER ADVANCING 1 LINES
  15461. 085500         WRITE PRT-REC FROM HDR-9-VR2 AFTER ADVANCING 1 LINES
  15462. 085600         ADD 6 TO LINE-CNT
  15463. 085700         GO TO 4228-EXIT-HDR-VR2-3.
  15464. 085800     IF HLD-REC-TYPE = "VR3D"
  15465. 085900         WRITE PRT-REC FROM HDR-5-VR3 AFTER ADVANCING 2 LINES
  15466. 086000         WRITE PRT-REC FROM HDR-6-VR3 AFTER ADVANCING 1 LINES
  15467. 086100         WRITE PRT-REC FROM HDR-7-VR3 AFTER ADVANCING 1 LINES
  15468. 086200         WRITE PRT-REC FROM HDR-8-VR3 AFTER ADVANCING 1 LINES
  15469. 086300         WRITE PRT-REC FROM HDR-9-VR3 AFTER ADVANCING 1 LINES
  15470. 086400         ADD 6 TO LINE-CNT
  15471. 086500         GO  TO 4228-EXIT-HDR-VR2-3.
  15472. 086600 4228-EXIT-HDR-VR2-3.
  15473. 086700     EXIT.
  15474. 086800 4230-PRT-SPACES.
  15475. 086900     IF SW-DET-VR2-3 = 0  GO TO 4250-HDNG-EXIT.
  15476. 087000     MOVE SPACES TO PRT-REC.
  15477. 087100     WRITE PRT-REC AFTER ADVANCING 1 LINES.
  15478. 087200     ADD 1 TO LINE-CNT.
  15479. 087300 4250-HDNG-EXIT.
  15480. 087400     EXIT.
  15481. 087500 4300-DET-REC-LINE.
  15482. 087600     IF S-KEY-1A = "VB1D"
  15483. 087700         MOVE S-KEY-1A TO HLD-KEY-1A-S
  15484. 087800      ELSE
  15485. 087900         MOVE REC-TYPE-3529-VR1-S1 TO H-REC-TYPE-S1
  15486. 088000         MOVE FMT-NO-3576-VR1-S1 TO H-FMT-NO-HLD-S1
  15487. 088100         MOVE FMT-CD-3579-VR1-S1 TO H-FMT-CD-HLD-S1
  15488. 088200         MOVE RNG-SITE-ID-3528-VR1-S1 TO H-RNG-SITE-NUM-S1.
  15489. 088300     IF  (HLD-KEY-1A-S NOT = HLD-REC-TYPE)
  15490. 088400        OR (HLD-KEY-1A-S = "VR1D" AND HLD-REC-TYPE = "VR1D")
  15491. 088500        GO TO 4305-NOT-EQ.
  15492. 088600         MOVE 0 TO SW2-3
  15493. 088700         MOVE 0 TO SW-DET-VR2-3
  15494. 088800         PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP
  15495. 088900         GO  TO 4320-RET-SORT.
  15496. 089000 4305-NOT-EQ.
  15497. 089100     IF  S-KEY-1A = "9999"  GO TO 4350-EXIT-DET.
  15498. 089200     IF (HLD-REC-TYPE = "VB1D") AND (REC-TYPE-3529-VR2-S1 = "VR"
  15499. 089300         AND FMT-NO-3576-VR1-S1 = "1")
  15500. 089400          MOVE 0 TO PAGE-CNT.
  15501. 089500     IF (H-RNG-SITE-NUM-S1 NOT = HLD-RNG-SITE-NUM)
  15502. 089600         MOVE 66 TO LINE-CNT.
  15503. 089700     PERFORM 4460-CHK-WH-REC THRU 4470-EXIT-WH-REC.
  15504. 089800     IF (HLD-REC-TYPE = "VB1D" OR "VR1D")
  15505. 089900         MOVE 66 TO LINE-CNT.
  15506. 090000     MOVE "1" TO SW2-3.
  15507. 090100     MOVE 1 TO SW-DET-VR2-3
  15508. 090200     PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP.
  15509. 090300 4320-RET-SORT.
  15510. 090400     RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH
  15511. 090500            MOVE "9999" TO S-KEY-1A.
  15512. 090600     IF EOR-SWITCH = 1 GO TO 4350-EXIT-DET.
  15513. 090700 4350-EXIT-DET.
  15514. 090800     EXIT.
  15515. 090900 4400-PRNT-DET-LINE.
  15516. 091000     PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
  15517. 091100     IF  S-KEY-1A = "VB1D"
  15518. 091200     PERFORM 4500-PRNT-VB THRU 4800-EXIT-PRT-DET
  15519. 091300     GO  TO  4450-EXIT-CHK-REC-TYP.
  15520. 091400     IF REC-TYPE-3529-VR1-S1 = "VR" AND FMT-NO-3576-VR1-S1 = "1"
  15521. 091500         PERFORM 4550-PRNT-VR1 THRU 4800-EXIT-PRT-DET
  15522. 091600         GO  TO 4450-EXIT-CHK-REC-TYP.
  15523. 091700 4410-CHK-2-3.
  15524. 091800     IF REC-TYPE-3529-VR2-S1 = "VR" AND FMT-NO-3576-VR2-S1 = "2"
  15525. 091900         PERFORM 4600-PRNT-VR2 THRU 4800-EXIT-PRT-DET
  15526. 092000         GO  TO 4450-EXIT-CHK-REC-TYP.
  15527. 092100     IF REC-TYPE-3529-VR3-S1 = "VR" AND FMT-NO-3576-VR3-S1 = "3"
  15528. 092200         PERFORM 4650-PRNT-VR3 THRU 4800-EXIT-PRT-DET
  15529. 092300         GO  TO 4450-EXIT-CHK-REC-TYP.
  15530. 092400 4450-EXIT-CHK-REC-TYP.
  15531. 092500     EXIT.
  15532. 092600 4460-CHK-WH-REC.
  15533. 092700     IF S-KEY-1A = "VB1D"
  15534. 092800         MOVE REC-TYPE-3529-VB-S1 TO REC-TYPE-HLD
  15535. 092900         MOVE FMT-NO-3576-VB-S1 TO FMT-NO-HLD
  15536. 093000         MOVE FMT-CD-3579-VB-S1 TO FMT-CD-HLD
  15537. 093100         GO TO 4470-EXIT-WH-REC.
  15538. 093200     IF (REC-TYPE-3529-VR1-S1 = "VR") AND
  15539. 093300          (FMT-NO-3576-VR1-S1 = "1"
  15540. 093400          OR "2" OR "3")
  15541. 093500         MOVE REC-TYPE-3529-VR1-S1 TO HLD-REC-TYPE
  15542. 093600         MOVE FMT-NO-3576-VR1-S1 TO FMT-NO-HLD
  15543. 093700         MOVE FMT-CD-3579-VR1-S1 TO FMT-CD-HLD
  15544. 093800         MOVE RNG-SITE-ID-3528-VR1-S1  TO
  15545. 093900              HLD-RNG-SITE-NUM.
  15546. 094000 4470-EXIT-WH-REC.
  15547. 094100     EXIT.
  15548. 094200 4500-PRNT-VB.
  15549. 094300     MOVE REC-TYPE-3529-VB-S1    TO  REC-TYPE-3529-VB-P1.
  15550. 094400     MOVE FMT-NO-3576-VB-S1      TO  FMT-NO-3576-VB-P1.
  15551. 094500     MOVE FMT-CD-3579-VB-S1      TO  FMT-CD-3579-VB-P1.
  15552. 094600     MOVE ADM-ST-0003-VB-S1      TO  ADM-ST-0003-VB-P1.
  15553. 094700     MOVE ADM-DI-0003-VB-S1      TO  ADM-DI-0003-VB-P1.
  15554. 094800     MOVE ADM-RA-0003-VB-S1      TO  ADM-RA-0003-VB-P1.
  15555. 094900     MOVE ADM-PU-0003-VB-S1      TO  ADM-PU-0003-VB-P1.
  15556. 095000     MOVE CLMTC-ADJ-FCTR-3547-VB-S1  TO CLMTC-ADJ-FCTR-3547-VB-P1.
  15557. 095100     MOVE DATA-DT-6618-VB-S1     TO  DATA-DT-6618-VB-P1.
  15558. 095200     MOVE ACT-CD-7350-VB-S1      TO  ACT-CD-7350-VB-P1.
  15559. 095300     MOVE LINE-NO-3578-VB-S1     TO  LINE-NO-3578-VB-P1.
  15560. 095400     MOVE SWA-3507-VB-S1         TO  SWA-3507-VB-P1.
  15561. 095500     MOVE TRN-NUM-3508-VB-S1     TO  TRN-NUM-3508-VB-P1.
  15562. 095600     MOVE SWA-PCT-3516-VB-S1     TO  SWA-PCT-3516-VB-P1.
  15563. 095700     MOVE RNG-SITE-ID-3528-VB-S1 TO  RNG-SITE-ID-3528-VB-P1.
  15564. 095800     MOVE STRATUM-NUM-3906-VB-S1 TO  STRATUM-NUM-3906-VB-P1.
  15565. 095900     MOVE ALLOT-NUM-0968-VB-S1   TO  ALLOT-NUM-0968-VB-P1.
  15566. 096000     MOVE PASTURE-NUM-3905-VB-S1 TO  PASTURE-NUM-3905-VB-P1.
  15567. 096100     MOVE VEG-SUB-TYPE-2706-VB-S1  TO  VEG-SUB-TYPE-2706-VB-P1.
  15568. 096200     MOVE RNG-ECOL-COND-CLS-2625-VB-S1 TO
  15569. 096300         RNG-ECOL-COND-CLS-2625-VB-P1.
  15570. 096400     MOVE PCT-SLP-3874-VB-S1     TO  PCT-SLP-3874-VB-P1.
  15571. 096500     MOVE ASPT-6523-VB-S1        TO  ASPT-6523-VB-P1.
  15572. 096600     MOVE L-FORM-5132-VB-S1      TO  L-FORM-5132-VB-P1.
  15573. 096700     MOVE SOIL-PHAS-4649-VB-S1   TO  SOIL-PHAS-4649-VB-P1.
  15574. 096800     WRITE PRT-REC FROM HDR-10-DET-VB AFTER ADVANCING 2 LINES.
  15575. 096900     ADD 2 TO LINE-CNT.
  15576. 097000     GO  TO 4800-EXIT-PRT-DET.
  15577. 097100 4550-PRNT-VR1.
  15578. 097200     MOVE REC-TYPE-3529-VR1-S1   TO  REC-TYPE-3529-VR1-P1.
  15579. 097300     MOVE FMT-NO-3576-VR1-S1     TO  FMT-NO-3576-VR1-P1.
  15580. 097400     MOVE FMT-CD-3579-VR1-S1     TO  FMT-CD-3579-VR1-P1.
  15581. 097500     MOVE ADM-ST-0003-VR1-S1     TO  ADM-ST-0003-VR1-P1.
  15582. 097600     MOVE DATA-DT-6618-VR1-S1    TO  DATA-DT-6618-VR1-P1.
  15583. 097700     MOVE ACT-CD-7350-VR1-S1     TO  ACT-CD-7350-VR1-P1.
  15584. 097800     MOVE RNG-SITE-ID-3528-VR1-S1  TO  RNG-SITE-ID-3528-VR1-P1.
  15585. 097900     MOVE RNG-SITE-NAM-3914-VR1-S1 TO  RNG-SITE-NAM-3914-VR1-P1.
  15586. 098000     MOVE PRECIP-ZONE-LOW-3909-VR1-S1 TO
  15587. 098100          PRECIP-ZONE-LOW-3909-VR1-P1.
  15588. 098200     MOVE PRECIP-ZONE-HI-3909-VR1-S1 TO
  15589. 098300         PRECIP-ZONE-HI-3909-VR1-P1.
  15590. 098400     MOVE SSF-VAL-AVG-4818-VR1-S1 TO  SSF-VAL-AVG-4818-VR1-P1.
  15591. 098500     MOVE POTN-PPA-3930-VR1-S1(1) TO POTN-PPA1-3930-VR1-P1.
  15592. 098600     MOVE POTN-PPA-3930-VR1-S1(2) TO POTN-PPA2-3930-VR1-P1.
  15593. 098700     MOVE POTN-PPA-3930-VR1-S1(3)  TO  POTN-PPA3-3930-VR1-P1.
  15594. 098800     WRITE PRT-REC FROM HDR-10-DET-VR1 AFTER ADVANCING 2 LINES.
  15595. 098900     ADD 2 TO LINE-CNT.
  15596. 099000     GO  TO 4800-EXIT-PRT-DET.
  15597. 099100 4600-PRNT-VR2.
  15598. 099200     MOVE REC-TYPE-3529-VR2-S1   TO  REC-TYPE-3529-VR2-P1.
  15599. 099300     MOVE FMT-NO-3576-VR2-S1     TO  FMT-NO-3576-VR2-P1.
  15600. 099400     MOVE FMT-CD-3579-VR2-S1     TO  FMT-CD-3579-VR2-P1.
  15601. 099500     MOVE ADM-ST-0003-VR2-S1     TO  ADM-ST-0003-VR2-P1.
  15602. 099600     MOVE DATA-DT-6618-VR2-S1    TO  DATA-DT-6618-VR2-P1.
  15603. 099700     MOVE ACT-CD-7350-VR2-S1     TO  ACT-CD-7350-VR2-P1.
  15604. 099800     MOVE RNG-SITE-ID-3528-VR2-S1  TO  RNG-SITE-ID-3528-VR2-P1.
  15605. 099900     MOVE LINE-NO-3578-VR2-S1    TO  LINE-NO-3578-VR2-P1.
  15606. 100000     MOVE PLANT-CD-2646-VR2-S1(1)  TO PLANT-CD1-2646-VR2-P1.
  15607. 100100     MOVE POTN-PCT-3535-VR2-S1(1)  TO  POTN-PCT1-3535-VR2-P1.
  15608. 100200     MOVE PLANT-CD-2646-VR2-S1(2)  TO  PLANT-CD2-2646-VR2-P1.
  15609. 100300     MOVE POTN-PCT-3535-VR2-S1(2)  TO  POTN-PCT2-3535-VR2-P1.
  15610. 100400     MOVE PLANT-CD-2646-VR2-S1(3)  TO  PLANT-CD3-2646-VR2-P1.
  15611. 100500     MOVE POTN-PCT-3535-VR2-S1(3)  TO  POTN-PCT3-3535-VR2-P1.
  15612. 100600     MOVE PLANT-CD-2646-VR2-S1(4)  TO  PLANT-CD4-2646-VR2-P1.
  15613. 100700     MOVE POTN-PCT-3535-VR2-S1(4)  TO  POTN-PCT4-3535-VR2-P1.
  15614. 100800     WRITE PRT-REC FROM HDR-10-DET-VR2 AFTER ADVANCING 2 LINES.
  15615. 100900     ADD 2 TO LINE-CNT.
  15616. 101000     GO  TO 4800-EXIT-PRT-DET.
  15617. 101100 4650-PRNT-VR3.
  15618. 101200     MOVE REC-TYPE-3529-VR3-S1   TO  REC-TYPE-3529-VR3-P1.
  15619. 101300     MOVE FMT-NO-3576-VR3-S1     TO  FMT-NO-3576-VR3-P1.
  15620. 101400     MOVE FMT-CD-3579-VR3-S1     TO  FMT-CD-3579-VR3-P1.
  15621. 101500     MOVE ADM-ST-0003-VR3-S1     TO  ADM-ST-0003-VR3-P1.
  15622. 101600     MOVE DATA-DT-6618-VR3-S1    TO  DATA-DT-6618-VR3-P1.
  15623. 101700     MOVE ACT-CD-7350-VR3-S1     TO  ACT-CD-7350-VR3-P1.
  15624. 101800     MOVE RNG-SITE-ID-3528-VR3-S1  TO  RNG-SITE-ID-3528-VR3-P1.
  15625. 101900     MOVE LINE-NO-3578-VR3-S1 TO LINE-NO-3578-VR3-P1.
  15626. 102000     MOVE SOIL-PHAS-4649-VR3-S1(1) TO  SOIL-PHAS1-4649-VR3-P1.
  15627. 102100     MOVE SOIL-NAM-4648-VR3-S1(1) TO SOIL-NAM1-4648-VR3-P1.
  15628. 102200     MOVE SOIL-PHAS-4649-VR3-S1(2) TO  SOIL-PHAS2-4649-VR3-P1.
  15629. 102300     MOVE SOIL-NAM-4648-VR3-S1(2)  TO  SOIL-NAM2-4648-VR3-P1.
  15630. 102400     WRITE PRT-REC FROM HDR-10-DET-VR3 AFTER ADVANCING 2 LINES.
  15631. 102500     ADD 2 TO LINE-CNT.
  15632. 102600 4800-EXIT-PRT-DET.
  15633. 102700     EXIT.
  15634. 102800 DUMMY-SECTION.
  15635. 102900 4830-DUMMY.
  15636. 103000     EXIT.
  15637. 103100 END-OF-JOB.
  15638. 000000*-----------------------------------------------------------------
  15639. 000100 IDENTIFICATION DIVISION.
  15640. 000200 PROGRAM-ID. ES320E.
  15641. 000300*        EDIT/UPDATE OF STRATIFICATION (VB) AND
  15642. 000400*            ECOLOGICAL SITE (VR) FORMATS.
  15643. 000500*
  15644. 000600 AUTHOR. CORA FISCHER 037.
  15645. 000700 INSTALLATION.  BLM-DENVER.
  15646. 000800 DATE-WRITTEN.   08/05/79.
  15647. 000900 DATE-COMPILED.
  15648. 001000*          BUILDS VB-WORK-FILE FROM VB RECORDS, BUILDS
  15649. 001100*          VM-WORK-FILE FROM VR1D RECORDS.
  15650. 001200 ENVIRONMENT DIVISION.
  15651. 001300 CONFIGURATION SECTION.
  15652. 001400 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  15653. 001500 OBJECT-COMPUTER.  LEVEL-66-ASCII SEQUENCE IS EBCDIC.
  15654. 001600 INPUT-OUTPUT SECTION.
  15655. 001700 FILE-CONTROL.
  15656. 001800     SELECT VR-VB-OT-FILE ASSIGN TO D1
  15657. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  15658. 002000     SELECT VM-WORK-FILE ASSIGN TO U1
  15659. 002100         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  15660. 002200     SELECT VB-WORK-FILE ASSIGN TO B1
  15661. 002300         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  15662. 002400     SELECT VR-VB-IN-FILE ASSIGN TO I1
  15663. 002500         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  15664. 002600     SELECT PRINTFILE ASSIGN TO P1
  15665. 002700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  15666. 002800 DATA DIVISION.
  15667. 002900 SUB-SCHEMA SECTION.
  15668. 003000 DB  CODVAL2 WITHIN BLMDIC.
  15669. 003100 FILE SECTION.
  15670. 003200 FD  VR-VB-IN-FILE
  15671. 003300     CODE-SET IS GBCD
  15672. 003400     LABEL RECORDS ARE STANDARD
  15673. 003500     DATA RECORD IS VR-VB-IN-REC.
  15674. 003600 01  VR-VB-IN-REC.
  15675. 003700     03  REC-TYP-I1           PIC X(4).
  15676. 003800     03  FILLER               PIC X(58).
  15677. 003900     03  RNG-ECOL-COND-CLS-I1 PIC X.
  15678. 004000     03  FILLER               PIC X(32).
  15679. 004100 FD  VB-WORK-FILE
  15680. 004200     CODE-SET IS GBCD
  15681. 004300     LABEL RECORDS ARE STANDARD
  15682. 004400     DATA RECORD IS VB-WORK-REC.
  15683. 004500 01  VB-WORK-REC  PIC X(96).
  15684. 004600 FD  VM-WORK-FILE
  15685. 004700     CODE-SET IS GBCD
  15686. 004800     LABEL RECORDS ARE STANDARD
  15687. 004900     DATA RECORD IS VM-WORK-REC.
  15688. 005000 01  VM-WORK-REC.
  15689. 005100     03  REC-TYP-U1   PIC X(4).
  15690. 005200     03  SD-U1.
  15691. 005300         05  ST-U1    PIC XX.
  15692. 005400         05  DS-U1    PIC XX.
  15693. 005500     03  DATE-U1      PIC X(6).
  15694. 005600     03  ACT-U1       PIC X.
  15695. 005700     03  STK-RATE-U1  PIC X.
  15696. 005800     03  RNG-SITE-U1  PIC X(11).
  15697. 005900     03  FILLER       PIC X(57).
  15698. 006000 FD  VR-VB-OT-FILE
  15699. 006100     CODE-SET IS GBCD
  15700. 006200     LABEL RECORDS ARE STANDARD
  15701. 006300     DATA RECORD IS VR-VB-OT-REC.
  15702. 006400 01  VR-VB-OT-REC  PIC X(96).
  15703. 006500 FD  PRINTFILE
  15704. 006600     CODE-SET IS GBCD
  15705. 006700     LABEL RECORDS ARE STANDARD
  15706. 006800     DATA RECORD IS PRT-REC.
  15707. 006900 01  PRT-REC  PIC X(132).
  15708. 007000 WORKING-STORAGE SECTION.
  15709. 007100 77  I                 PIC    9  VALUE ZERO.
  15710. 007200 77  VB-IN-CNT         PIC 99  VALUE ZERO,
  15711. 007300 77  RNG-SITE-HLD      PIC X(11)  VALUE SPACE.
  15712. 007400 77  ERR-FREE           PIC    9  VALUE 0.
  15713. 007500 77  RNGE-SITE-SAME     PIC    9  VALUE 0.
  15714. 007600 77  SWITCH-LINE1       PIC    9  VALUE ZERO.
  15715. 007700 77  PAGE-CTR          PIC 9(6)   VALUE ZERO.
  15716. 007800 77  LINE-CTR          PIC   99    VALUE ZERO.
  15717. 007900 77  INPUT-CTR         PIC 9(5)   VALUE ZERO.
  15718. 008000 77  GOOD-CTR          PIC 9(5)   VALUE ZERO.
  15719. 008100 77  ERROR-CTR         PIC 9(5)   VALUE ZERO.
  15720. 008200 77  DRP-ERR-CTR       COMP-6    VALUE ZERO.
  15721. 008300 77  UNKWN-LITRL      PIC X(15) VALUE "UNKNOWN        ".
  15722. 008400 77  DB-ERR-PARA    PIC X(4).
  15723. 008500 77  RNG-SITE-TALLY   COMP-6.
  15724. 008600 77  PLU-HOLD         PIC X(2).
  15725. 008700 01  NAMES-HOLD.
  15726. 008800     05  FUNC-HLD.
  15727. 008900         10  ST-NM-HLD           PIC       X(10).
  15728. 009000         10  FILLER              PIC       X.
  15729. 009100     05  EXPL-HLD.
  15730. 009200         10  DIST-NM-HLD         PIC       X(10).
  15731. 009300         10  FILLER              PIC       X.
  15732. 009400         10  RA-NM-HLD           PIC       X(12).
  15733. 009500         10  FILLER              PIC       X.
  15734. 009600         10  PU-NM-HLD           PIC       X(15).
  15735. 009700         10  FILLER              PIC       X.
  15736. 009800 01  REC-TYP-HLD-2.
  15737. 009900     05  H-REC-TYP-VB1Z          PIC       XX.
  15738. 010000     05  H-FMT-NUM-VB1Z          PIC       9(1).
  15739. 010100     05  H-FORMAT-CD-VB1Z        PIC       X(1).
  15740. 010200 01  HLD-ST                      PIC       XX.
  15741. 010300 01  HLD-DIST                    PIC       XX.
  15742. 010400 01  HLD-RA                      PIC       XX.
  15743. 010500 01  HLD-PU                      PIC       XX.
  15744. 010600 01  HLD-CLMTC-ADJ-FCTR          PIC       X(5).
  15745. 010700 01  HLD-RNG-SITE-ID            PIC       X(11).
  15746. 010800 01  EOF-SWITCH        PIC 9     VALUE ZERO.
  15747. 010900     88  EOF           VALUE 1.
  15748. 011000 01  HEADING-SWITCH    PIC 9   VALUE ZERO.
  15749. 011100     88  ST-DIST-PLU-CHANGE      VALUE 1.
  15750. 011200     COPY DBSTATUS IN TPCOBOLIB.
  15751. 011300 01  AS-OF-DATE.
  15752. 011400     03  AS-OF-YR  PIC X(02).
  15753. 011500     03  AS-OF-MO  PIC 9(02).
  15754. 011600     03  AS-OF-DA  PIC X(02).
  15755. 011700 01  MONTH-TABLE.
  15756. 011800     03  MO-TAB.
  15757. 011900         05  FILLER  PIC X(03)  VALUE "JAN".
  15758. 012000         05  FILLER  PIC X(03)  VALUE "FEB".
  15759. 012100         05  FILLER  PIC X(03)  VALUE "MAR".
  15760. 012200         05  FILLER  PIC X(03)  VALUE "APR".
  15761. 012300         05  FILLER  PIC X(03)  VALUE "MAY".
  15762. 012400         05  FILLER  PIC X(03)  VALUE "JUN".
  15763. 012500         05  FILLER  PIC X(03)  VALUE "JUL".
  15764. 012600         05  FILLER  PIC X(03)  VALUE "AUG".
  15765. 012700         05  FILLER  PIC X(03)  VALUE "SEP".
  15766. 012800         05  FILLER  PIC X(03)  VALUE "OCT".
  15767. 012900         05  FILLER  PIC X(03)  VALUE "NOV".
  15768. 013000         05  FILLER  PIC X(03)  VALUE "DEC".
  15769. 013100     03  MON  REDEFINES  MO-TAB  PIC X(03)  OCCURS 12 TIMES.
  15770. 013200 01  HDR-1.
  15771. 013300     05  FILLER                  PIC       X(4)      VALUE SPACES.
  15772. 013400     05  FILLER                  PIC       X(5)      VALUE
  15773. 013500         "PCN: ".
  15774. 013600     05  HDR-PCN                 PIC       X(8).
  15775. 013700     05  FILLER                  PIC       X(7)      VALUE
  15776. 013800         " AS OF ".
  15777. 013900     05  HDR-DD                  PIC       XX.
  15778. 014000     05  FILLER                  PIC       X         VALUE SPACE.
  15779. 014100     05  HDR-MMM                 PIC       XXX.
  15780. 014200     05  FILLER                  PIC       X         VALUE SPACE.
  15781. 014300     05  HDR-YR                  PIC       XX.
  15782. 014400     05  FILLER                  PIC       X(09)     VALUE SPACES.
  15783. 014500     05  FILLER                  PIC       X(48)     VALUE
  15784. 014600         "USDI- BUR OF LAND MGT  ECOLOGICAL SITE INVENTORY".
  15785. 014700     05  FILLER                  PIC       X(29)     VALUE SPACES.
  15786. 014800     05  FILLER                  PIC       X(7)      VALUE
  15787. 014900         "PAGE:  ".
  15788. 015000     05  HDR-PG                  PIC       ZZZZZ9.
  15789. 015100 01  HDR-2.
  15790. 015200     05  FILLER                  PIC       X(17)     VALUE SPACES.
  15791. 015300     05  FILLER                  PIC       X(8)      VALUE
  15792. 015400         "STATE:  ".
  15793. 015500     05  HDR-ST-NM                  PIC       X(15).
  15794. 015600     05  FILLER                  PIC       X(16)     VALUE SPACES.
  15795. 015700     05  FILLER                  PIC       X(7)      VALUE
  15796. 015800         "DIST:  ".
  15797. 015900     05  HDR-DIST-NM                PIC       X(15).
  15798. 016000     05  FILLER                  PIC       X(15)     VALUE SPACES.
  15799. 016100     05  HDR-VB-EDIT             PIC       X(22)     VALUE
  15800. 016200         "VB  EDIT ERROR LISTING".
  15801. 016300     05  FILLER                  PIC       X(17)     VALUE SPACES.
  15802. 016400 01  VB-HDR-REC1.
  15803. 016500     05  FILLER                  PIC       X(10)     VALUE SPACES.
  15804. 016600     05  FILLER                  PIC       X(33)     VALUE
  15805. 016700         "REC-TYP          ST          DIST".
  15806. 016800     05  FILLER                  PIC       X(29)     VALUE
  15807. 016900     "          RA            PLU  ".
  15808. 017000     05  FILLER                  PIC       X(36)     VALUE
  15809. 017100         "          CLIMATIC ADJ          DATE".
  15810. 017200     05  FILLER                  PIC       X(24)     VALUE
  15811. 017300         "          ACTN          ".
  15812. 017400 01  VB-HDR-REC2.
  15813. 017500     05  FILLER                  PIC       X(12)     VALUE SPACES.
  15814. 017600     05  FILLER                  PIC       X(31)     VALUE
  15815. 017700         "1-4           5-6           7-8".
  15816. 017800     05  FILLER                  PIC       X(43)     VALUE
  15817. 017900         "         9-10          11-12               ".
  15818. 018000     05  FILLER                  PIC       X(35)     VALUE
  15819. 018100         "13-17            18-23           24".
  15820. 018200     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15821. 018300 01  VB-HDR-REC3.
  15822. 018400     05  FILLER                  PIC       X(12)     VALUE SPACES.
  15823. 018500     05  FILLER                  PIC       X(4)      VALUE "XXXX".
  15824. 018600     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15825. 018700     05  FILLER                  PIC       XX        VALUE "XX".
  15826. 018800     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15827. 018900     05  FILLER                  PIC       XX        VALUE "XX".
  15828. 019000     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15829. 019100     05  FILLER                  PIC       XX        VALUE "XX".
  15830. 019200     05  FILLER                  PIC       X(13)     VALUE SPACES.
  15831. 019300     05  FILLER                  PIC       XX        VALUE "XX".
  15832. 019400     05  FILLER                  PIC       X(16)     VALUE SPACES.
  15833. 019500     05  FILLER                  PIC       X(5)      VALUE
  15834. 019600         "XXXXX".
  15835. 019700     05  FILLER                  PIC       X(12)     VALUE SPACES.
  15836. 019800     05  FILLER                  PIC       X(6)      VALUE
  15837. 019900         "XXXXXX".
  15838. 020000     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15839. 020100     05  FILLER                  PIC       X         VALUE "X".
  15840. 020200     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15841. 020300 01  VB-DET-LN1.
  15842. 020400     05  FILLER                  PIC       X(12)     VALUE SPACES.
  15843. 020500     05  REC-TYP-P               PIC       XXXX.
  15844. 020600     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15845. 020700     05  ST-P                    PIC       XX.
  15846. 020800     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15847. 020900     05  DIST-P                  PIC       XX.
  15848. 021000     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15849. 021100     05  RS-P                    PIC       XX.
  15850. 021200     05  FILLER                  PIC       X(13)     VALUE SPACES.
  15851. 021300     05  PU-P                    PIC       XX.
  15852. 021400     05  FILLER                  PIC       X(16)     VALUE SPACES.
  15853. 021500     05  CLIMATIC-ADJ-P          PIC       X(5).
  15854. 021600     05  FILLER                  PIC       X(12)     VALUE SPACES.
  15855. 021700     05  DATE-P                  PIC       X(6).
  15856. 021800     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15857. 021900     05  ACTN-P                  PIC       X.
  15858. 022000     05  FILLER                 PIC       X(11)     VALUE SPACES.
  15859. 022100 01  VB-ASTERISK-LN1.
  15860. 022200     05  FILLER                  PIC       X(12)     VALUE SPACES.
  15861. 022300     05  REC-TYP-ERR             PIC       XXXX.
  15862. 022400     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15863. 022500     05  ST-ERR                  PIC       XX.
  15864. 022600     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15865. 022700     05  DIST-ERR                PIC       XX.
  15866. 022800     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15867. 022900     05  RS-ERR                  PIC       XX.
  15868. 023000     05  FILLER                  PIC       X(13)     VALUE SPACES.
  15869. 023100     05  PU-ERR                  PIC       XX.
  15870. 023200     05  FILLER                  PIC       X(16)     VALUE SPACES.
  15871. 023300     05  CLIMATIC-ADJ-ERR        PIC       X(5).
  15872. 023400     05  FILLER                  PIC       X(12)     VALUE SPACES.
  15873. 023500     05  DATE-ERR                PIC       X(6).
  15874. 023600     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15875. 023700     05  ACTN-ERR                PIC       X.
  15876. 023800     05  FILLER                  PIC       X(11)     VALUE SPACES.
  15877. 023900 01  VB-HDR-REC4.
  15878. 024000     05  FILLER                  PIC       X(5)      VALUE SPACES.
  15879. 024100     05  FILLER                  PIC       X(40)     VALUE
  15880. 024200         "LIN NUM  SWA  TRNSCT  % SWA  RNGE SITE  ".
  15881. 024300     05  FILLER                  PIC       X(42)     VALUE
  15882. 024400         "STRTUM  ALLOT  PASTURE  VEG SUB  COND CL  ".
  15883. 024500     05  FILLER                  PIC       X(45)     VALUE
  15884. 024600         "% SLOPE  SLOPE ASP  LAND FORM  SOIL PHASE    ".
  15885. 024700 01  VB-HDR-REC5.
  15886. 024800     05  FILLER                  PIC       X(6)      VALUE SPACES.
  15887. 024900     05  FILLER                  PIC       X(47)     VALUE
  15888. 025000         "25-28  29-32  33-34  35-37    38-48     49-52  ".
  15889. 025100     05  FILLER                  PIC       X(40)     VALUE
  15890. 025200         "53-56   57-58    59-62     63      64-66".
  15891. 025300     05  FILLER                  PIC       X(39)     VALUE
  15892. 025400        "     67-68      69-71       72-76      ".
  15893. 025500 01  VB-HDR-REC6.
  15894. 025600      05  FILLER                 PIC       X(7)      VALUE SPACES.
  15895. 025700     05  FILLER                 PIC       X(4)      VALUE "XXXX".
  15896. 025800      05  FILLER                 PIC       XXX       VALUE SPACES.
  15897. 025900      05  FILLER                 PIC       X(4)      VALUE "XXXX".
  15898. 026000      05  FILLER                 PIC       X(4)      VALUE SPACES.
  15899. 026100      05  FILLER                 PIC       XX        VALUE "XX".
  15900. 026200      05  FILLER                 PIC       X(4)      VALUE SPACES.
  15901. 026300      05  FILLER                 PIC       XXX       VALUE "XXX".
  15902. 026400      05  FILLER                 PIC       XX        VALUE SPACES.
  15903. 026500      05  FILLER                 PIC       X(11)     VALUE
  15904. 026600              "XXXXXXXXXXX".
  15905. 026700      05  FILLER                 PIC       XXX       VALUE SPACES.
  15906. 026800      05  FILLER                 PIC       XXX       VALUE "XXX".
  15907. 026900      05  FILLER                 PIC       X(4)      VALUE SPACES.
  15908. 027000      05  FILLER                 PIC       X(4)      VALUE
  15909. 027100          "XXXX".
  15910. 027200      05  FILLER                 PIC       X(5)      VALUE SPACES.
  15911. 027300      05  FILLER                 PIC       XX        VALUE "XX".
  15912. 027400      05  FILLER                 PIC       X(6)      VALUE SPACES.
  15913. 027500      05  FILLER                 PIC       XXXX      VALUE "XXXX".
  15914. 027600      05  FILLER                 PIC       X(6)      VALUE SPACES.
  15915. 027700      05  FILLER                 PIC       X         VALUE "X".
  15916. 027800      05  FILLER                 PIC       X(7)      VALUE SPACES.
  15917. 027900      05  FILLER                 PIC       XXX       VALUE "XXX".
  15918. 028000      05  FILLER                 PIC       X(8)      VALUE SPACES.
  15919. 028100      05  FILLER                 PIC       XX        VALUE "XX".
  15920. 028200      05  FILLER                 PIC       X(8)      VALUE SPACES.
  15921. 028300      05  FILLER                 PIC       XXX       VALUE "XXX".
  15922. 028400      05  FILLER                 PIC       X(8)      VALUE SPACES.
  15923. 028500      05  FILLER                 PIC       X(5)      VALUE
  15924. 028600          "XXXXX".
  15925. 028700      05  FILLER                 PIC       X(6)      VALUE SPACES.
  15926. 028800 01  VB-DET-LN2.
  15927. 028900     05  FILLER                  PIC       X(7)      VALUE SPACES.
  15928. 029000     05  VB-LIN-NUM-P            PIC       XXXX.
  15929. 029100     05  FILLER                  PIC       XX       VALUE SPACES.
  15930. 029200     05  VB-SWA-P                PIC       XXXX.
  15931. 029300     05  FILLER                  PIC       X(4)     VALUE SPACES.
  15932. 029400     05  VB-TRN-P                 PIC       XX.
  15933. 029500     05  FILLER                  PIC       X(4)     VALUE SPACES.
  15934. 029600     05  VB-PCT-SWA-P              PIC       XXX.
  15935. 029700     05  FILLER                  PIC       XX       VALUE SPACES.
  15936. 029800     05  VB-RNGE-SITE-P          PIC       X(11).
  15937. 029900     05  FILLER                  PIC       XX       VALUE SPACES.
  15938. 030000     05  VB-STRTUM-P             PIC       XXXX.
  15939. 030100     05  FILLER                  PIC       X(4)      VALUE SPACES.
  15940. 030200     05  VB-ALLOT-P              PIC       XXXX.
  15941. 030300     05  FILLER                  PIC       X(5)      VALUE SPACES.
  15942. 030400     05  VB-PASTURE-P            PIC       XX.
  15943. 030500     05  FILLER                  PIC       X(6)     VALUE SPACES.
  15944. 030600     05  VB-VEG-SUB-P            PIC       XXXX.
  15945. 030700     05  FILLER                  PIC       X(6)     VALUE SPACES.
  15946. 030800     05  VB-COND-CL-P            PIC       X.
  15947. 030900     05  FILLER                  PIC       X(7)     VALUE SPACES.
  15948. 031000     05  VB-PCT-SLOPE-P            PIC       XXX.
  15949. 031100     05  FILLER                  PIC       X(8)     VALUE SPACES.
  15950. 031200     05  VB-SLOPE-ASP-P          PIC       XX.
  15951. 031300     05  FILLER                  PIC       X(8)     VALUE SPACES.
  15952. 031400     05  VB-LAND-FORM-P          PIC       XXX.
  15953. 031500     05  FILLER                  PIC       X(8)     VALUE SPACES.
  15954. 031600     05  VB-SOIL-PHASE-P         PIC       X(5).
  15955. 031700     05  FILLER                  PIC       X(6)     VALUE SPACES.
  15956. 031800 01  VB-ASTERISK-LN2.
  15957. 031900     05  FILLER                  PIC       X(7)      VALUE SPACES.
  15958. 032000     05  VB-LIN-NUM-ERR          PIC       XXXX.
  15959. 032100     05  FILLER                  PIC       XX       VALUE SPACES.
  15960. 032200     05  VB-SWA-ERR              PIC       XXXX.
  15961. 032300     05  FILLER                  PIC       X(4)     VALUE SPACES.
  15962. 032400     05  VB-TRNSCT-ERR           PIC       XX.
  15963. 032500     05  FILLER                  PIC       X(4)     VALUE SPACES.
  15964. 032600     05  VB-PCT-SWA-ERR            PIC       XXX.
  15965. 032700     05  FILLER                  PIC       XX       VALUE SPACES.
  15966. 032800     05  VB-RNGE-SITE-ERR        PIC       X(11).
  15967. 032900     05  VB-RNGE-SITE-ERR-RE REDEFINES VB-RNGE-SITE-ERR.
  15968. 033000        10  VB-RNGSITE-ERR-4    PIC      XXXX.
  15969. 033100        10  VB-RNGSITE-ERR-3    PIC      XXX.
  15970. 033200        10  VB-RNGSITE-ERR-ALL  PIC      XXXX.
  15971. 033300     05  FILLER                  PIC       XXX      VALUE SPACES.
  15972. 033400     05  VB-STRTUM-ERR           PIC       XXX.
  15973. 033500     05  FILLER                  PIC       X(4)     VALUE SPACES.
  15974. 033600     05  VB-ALLOT-ERR            PIC       XXXX.
  15975. 033700     05  FILLER                  PIC       X(5)     VALUE SPACES.
  15976. 033800     05  VB-PASTURE-ERR          PIC       XX.
  15977. 033900     05  FILLER                  PIC       X(6)     VALUE SPACES.
  15978. 034000     05  VB-VEG-SUB-ERR          PIC       XXXX.
  15979. 034100     05  FILLER                  PIC       X(6)     VALUE SPACES.
  15980. 034200     05  VB-COND-CL-ERR          PIC       X.
  15981. 034300     05  FILLER                  PIC       X(7)     VALUE SPACES.
  15982. 034400     05  VB-PCT-SLOPE-ERR          PIC       XXX.
  15983. 034500     05  FILLER                  PIC       X(8)     VALUE SPACES.
  15984. 034600     05  VB-SLOPE-ASP-ERR        PIC       XX.
  15985. 034700     05  FILLER                  PIC       X(8).
  15986. 034800     05  VB-LAND-FORM-ERR        PIC       XXX.
  15987. 034900     05  FILLER                  PIC       X(8)     VALUE SPACES.
  15988. 035000     05  VB-SOIL-PHASE-ERR       PIC       X(5).
  15989. 035100     05  FILLER                  PIC       X(6)     VALUE SPACES.
  15990. 035200 01  VR-HDR-ST.
  15991. 035300     05  FILLER                  PIC       X(17)    VALUE SPACES.
  15992. 035400     05  FILLER                  PIC       X(8)     VALUE
  15993. 035500         "STATE:  ".
  15994. 035600     05  HDR-VR-ST               PIC       X(15).
  15995. 035700     05  FILLER                  PIC       X(53)    VALUE SPACES.
  15996. 035800     05  HDR-VR-TIT              PIC       X(22).
  15997. 035900     05  FILLER                  PIC       X(17)    VALUE SPACES.
  15998. 036000 01  VR-HDR-REC1.
  15999. 036100     05  FILLER                  PIC       X(10)    VALUE SPACES.
  16000. 036200     05  FILLER                  PIC       X(47)    VALUE
  16001. 036300         "REC-TYP          ST          DATE          ACTN".
  16002. 036400     05  FILLER                 PIC       X(19)      VALUE
  16003. 036500         "      RANGE SITE NO".
  16004. 036600     05  FILLER                  PIC       X(56)     VALUE SPACES.
  16005. 036700 01  VR-HDR-REC2.
  16006. 036800     05  FILLER                  PIC       X(12)     VALUE SPACES.
  16007. 036900     05  FILLER                  PIC       X(4)      VALUE "1-4".
  16008. 037000     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16009. 037100     05  FILLER                  PIC       X(3)      VALUE "5-6".
  16010. 037200     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16011. 037300     05  FILLER                  PIC       X(5)      VALUE
  16012. 037400         "13-18".
  16013. 037500     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16014. 037600     05  FILLER                  PIC       XX        VALUE "19".
  16015. 037700     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16016. 037800     05  FILLER                  PIC       X(5)     VALUE "20-30".
  16017. 037900     05  FILLER                  PIC       X(60)     VALUE SPACES.
  16018. 038000 01  VR-HDR-REC3.
  16019. 038100     05  FILLER                  PIC       X(12)     VALUE SPACE.
  16020. 038200     05  FILLER                  PIC       XXXX      VALUE "XXXX".
  16021. 038300     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16022. 038400     05  FILLER                  PIC       XX        VALUE "XX".
  16023. 038500     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16024. 038600     05  FILLER                  PIC       X(6)      VALUE
  16025. 038700         "XXXXXX".
  16026. 038800     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16027. 038900     05  FILLER                  PIC       X         VALUE "X".
  16028. 039000     05  FILLER                 PIC       X(8)      VALUE SPACES.
  16029. 039100     05  FILLER                 PIC       X(11)     VALUE
  16030. 039200         "XXXXXXXXXXX".
  16031. 039300     05  FILLER                  PIC       X(56)     VALUE SPACES.
  16032. 039400 01  VR-HDR-DET-LN1.
  16033. 039500     05  FILLER                  PIC       X(12)     VALUE SPACES.
  16034. 039600     05  HDR-VR-REC-TYP-P        PIC       XXXX.
  16035. 039700     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16036. 039800     05  HDR-VR-ST-P             PIC       XX.
  16037. 039900     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16038. 040000     05  HDR-VR-DATE-P           PIC       X(6).
  16039. 040100     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16040. 040200     05  HDR-VR-ACTN-P           PIC       X.
  16041. 040300     05  FILLER                  PIC       X(8)      VALUE SPACES.
  16042. 040400     05  HDR-VR-RNG-SITE-NO-P    PIC       X(11).
  16043. 040500     05  FILLER                  PIC       X(57)     VALUE SPACES.
  16044. 040600 01  VR-HDR-ASTERISK-LN1.
  16045. 040700     05  FILLER                  PIC       X(12)     VALUE SPACES.
  16046. 040800     05  HDR-VR-REC-TYP-ERR      PIC       XXXX.
  16047. 040900     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16048. 041000     05  HDR-VR-ST-ERR           PIC       XX.
  16049. 041100     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16050. 041200     05  HDR-VR-DATE-ERR         PIC       X(6).
  16051. 041300     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16052. 041400     05  HDR-VR-ACTN-ERR         PIC       X.
  16053. 041500     05  FILLER                  PIC       X(8)     VALUE SPACES.
  16054. 041600     05  HDR-VR-RNG-SITE-NO-ERR  PIC       X(11).
  16055. 041700     05  VR-RNG-SITE-ERR REDEFINES HDR-VR-RNG-SITE-NO-ERR.
  16056. 041800         10  VR-RNGSITE-ERR-4        PIC      XXXX.
  16057. 041900         10  VR-RNGSITE-ERR-3        PIC      XXX.
  16058. 042000         10  VR-RNGSITE-ALL-ERR      PIC      XXXX.
  16059. 042100     05  FILLER                  PIC       X(57)     VALUE SPACES.
  16060. 042200 01  VR1-HDR-REC1.
  16061. 042300     05  FILLER                  PIC      X(5)      VALUE SPACES.
  16062. 042400     05  FILLER                  PIC      X(29)     VALUE
  16063. 042500         "LIN NUM        RNGE SITE NAME".
  16064. 042600     05  FILLER                  PIC      X(44)     VALUE
  16065. 042700         "      PRECIP       SOIL SURFACE       AVG YR".
  16066. 042800     05  FILLER                  PIC       X(41)    VALUE
  16067. 042900         "       FAVORABLE YR       UNFAVORABLE YR ".
  16068. 043000     05  FILLER                  PIC       X(13)    VALUE SPACES.
  16069. 043100 01  VR1-HDR-REC2.
  16070. 043200     05  FILLER                  PIC       X(6)      VALUE SPACES.
  16071. 043300     05  FILLER                  PIC       X(24)     VALUE
  16072. 043400         "31-34              35-42".
  16073. 043500     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16074. 043600     05  FILLER                  PIC       X(37)     VALUE
  16075. 043700         "43-46          47-49            50-55".
  16076. 043800     05  FILLER                  PIC       X(16)     VALUE
  16077. 043900         "           56-61".
  16078. 044000     05  FILLER                  PIC       X(15)     VALUE SPACES.
  16079. 044100     05  FILLER                  PIC       X(10)     VALUE
  16080. 044200         "62-67     ".
  16081. 044300     05  FILLER                  PIC       X(13)     VALUE SPACES.
  16082. 044400 01  VR1-HDR-REC3.
  16083. 044500     05  FILLER                  PIC       X(7)      VALUE SPACES.
  16084. 044600     05  FILLER                  PIC       XXXX      VALUE "XXXX".
  16085. 044700     05  FILLER                  PIC       X(5)      VALUE SPACES.
  16086. 044800     05  FILLER                  PIC       X(7)      VALUE SPACES.
  16087. 044900     05  FILLER                  PIC       X(8)      VALUE
  16088. 045000         "XXXXXXXX".
  16089. 045100     05  FILLER                  PIC       X(10)     VALUE SPACES.
  16090. 045200     05  FILLER                  PIC       XXXX      VALUE "XXXX".
  16091. 045300     05  FILLER                  PIC       X(12)     VALUE SPACES.
  16092. 045400     05  FILLER                  PIC       XXX       VALUE "XXX".
  16093. 045500     05  FILLER                  PIC       X(12)     VALUE SPACES.
  16094. 045600     05  FILLER                  PIC       X(7)      VALUE
  16095. 045700         "XXXXXXX".
  16096. 045800     05  FILLER                  PIC       X(10)     VALUE SPACES.
  16097. 045900     05  FILLER                  PIC       X(6)      VALUE
  16098. 046000         "XXXXXX".
  16099. 046100     05  FILLER                  PIC       X(14)     VALUE SPACES.
  16100. 046200     05  FILLER                  PIC       X(6)      VALUE
  16101. 046300       "XXXXXX".
  16102. 046400     05  FILLER                  PIC       X(4)      VALUE SPACES.
  16103. 046500     05  FILLER                  PIC       X(13)     VALUE SPACES.
  16104. 046600 01  VR1-HDR-DET-LN2.
  16105. 046700     05  FILLER                  PIC       X(7)      VALUE SPACES.
  16106. 046800     05  VR1-LIN-NUM-P           PIC       XXXX.
  16107. 046900     05  FILLER                  PIC       X(12)     VALUE SPACES.
  16108. 047000     05  VR1-RNGSITE-NM-P        PIC       X(8).
  16109. 047100     05  FILLER                  PIC       X(10)     VALUE SPACES.
  16110. 047200     05  VR1-PRECIP-P            PIC       XXXX.
  16111. 047300     05  FILLER                  PIC       X(12)     VALUE SPACES.
  16112. 047400     05  VR1-SOIL-SURF-P         PIC       XXX.
  16113. 047500     05  FILLER                  PIC       X(12)     VALUE SPACES.
  16114. 047600     05  VR1-AVG-YR-P            PIC       X(6).
  16115. 047700     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16116. 047800     05  VR1-FAVORABLE-YR-P      PIC       X(6).
  16117. 047900     05  FILLER                  PIC       X(14)     VALUE SPACES.
  16118. 048000     05  VR1-UNFAVORABLE-YR-P    PIC       X(6).
  16119. 048100     05  FILLER                  PIC       X(17)     VALUE SPACES.
  16120. 048200 01  VR1-HDR-ASTERISK-LN2.
  16121. 048300     05  FILLER                  PIC       X(7)      VALUE SPACES.
  16122. 048400     05  VR1-LIN-NUM-ERR         PIC       XXXX.
  16123. 048500     05  FILLER                  PIC       X(12)     VALUE SPACES.
  16124. 048600     05  VR1-RNGSITE-NM-ERR      PIC       X(8).
  16125. 048700     05  FILLER                  PIC       X(10)     VALUE SPACES.
  16126. 048800     05  VR1-PRECIP-ERR          PIC       XXXX.
  16127. 048900     05  FILLER                  PIC       X(12).
  16128. 049000     05  VR1-SOIL-SURF-ERR       PIC       XXX.
  16129. 049100     05  FILLER                  PIC       X(12)     VALUE SPACES.
  16130. 049200     05  VR1-AVG-YR-ERR          PIC       X(6).
  16131. 049300     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16132. 049400     05  VR1-FAVORABLE-YR-ERR    PIC       X(6).
  16133. 049500     05  FILLER                  PIC       X(14)     VALUE SPACES.
  16134. 049600     05  VR1-UNFAVORABLE-YR-ERR  PIC       X(6).
  16135. 049700     05  FILLER                  PIC       X(17)     VALUE SPACES.
  16136. 049800 01  VR2-HDR-REC1.
  16137. 049900     05  FILLER                  PIC       X(6)      VALUE SPACES.
  16138. 050000     05  FILLER                  PIC       X(49)     VALUE
  16139. 050100         "LIN NUM      PLANT CD      COMP PCT      PLANT CD".
  16140. 050200     05  FILLER                  PIC       X(21)     VALUE
  16141. 050300         "      COMP PCT       ".
  16142. 050400     05  FILLER                 PIC       X(57)     VALUE
  16143. 050500      "PLANT CD      COMP PCT      PLANT CD      COMP-PCT       ".
  16144. 050600 01  VR2-HDR-REC2.
  16145. 050700     05  FILLER                  PIC       X(7)      VALUE SPACES.
  16146. 050800     05  FILLER                  PIC       X(33)     VALUE
  16147. 050900         "31-34         35-41         42-44".
  16148. 051000     05  FILLER                  PIC       X(42)     VALUE
  16149. 051100         "         45-51         52-54         55-61".
  16150. 051200     05  FILLER                  PIC       X(42)     VALUE
  16151. 051300         "         62-64         65-71         72-74".
  16152. 051400     05  FILLER                  PIC       X(8)      VALUE SPACES.
  16153. 051500 01  VR2-HDR-REC3.
  16154. 051600     05  FILLER                  PIC       X(8)      VALUE SPACES.
  16155. 051700     05  FILLER                  PIC       XXXX      VALUE "XXXX".
  16156. 051800     05  FILLER                  PIC       X(8)      VALUE SPACES.
  16157. 051900     05  FILLER                  PIC       X(7)      VALUE
  16158. 052000         "XXXXXXX".
  16159. 052100     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16160. 052200     05  FILLER                  PIC       XXX       VALUE "XXX".
  16161. 052300     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16162. 052400     05  FILLER                  PIC       X(7)      VALUE
  16163. 052500         "XXXXXXX".
  16164. 052600     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16165. 052700     05  FILLER                  PIC       XXX       VALUE "XXX".
  16166. 052800     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16167. 052900     05  FILLER                  PIC       X(7)      VALUE
  16168. 053000         "XXXXXXX".
  16169. 053100     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16170. 053200     05  FILLER                  PIC       XXX       VALUE "XXX".
  16171. 053300     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16172. 053400     05  FILLER                  PIC       X(7)      VALUE
  16173. 053500         "XXXXXXX".
  16174. 053600     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16175. 053700     05  FILLER                  PIC       XXX       VALUE "XXX".
  16176. 053800     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16177. 053900 01  VR2-HDR-DET-LN2.
  16178. 054000     05  FILLER                  PIC       X(8)      VALUE SPACES.
  16179. 054100     05  VR2-LIN-NUM-P           PIC       XXXX.
  16180. 054200     05  FILLER                  PIC       X(8)      VALUE SPACES.
  16181. 054300     05  VR2-PLANT-CD1-P         PIC       X(7).
  16182. 054400     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16183. 054500     05  VR2-COMP-PCT1-P         PIC       XXX.
  16184. 054600     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16185. 054700     05  VR2-PLANT-CD2-P         PIC       X(7).
  16186. 054800     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16187. 054900     05  VR2-COMP-PCT2-P         PIC       XXX.
  16188. 055000     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16189. 055100     05  VR2-PLANT-CD3-P         PIC       X(7).
  16190. 055200     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16191. 055300     05  VR2-COMP-PCT3-P         PIC       XXX.
  16192. 055400     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16193. 055500     05  VR2-PLANT-CD4-P         PIC       X(7).
  16194. 055600     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16195. 055700     05  VR2-COMP-PCT4-P         PIC       XXX.
  16196. 055800     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16197. 055900 01  VR2-HDR-ASTERISK-LN2.
  16198. 056000     05  FILLER                  PIC       X(8)      VALUE SPACES.
  16199. 056100     05  VR2-LIN-NUM-ERR         PIC       XXXX.
  16200. 056200     05  FILLER                  PIC       X(8)     VALUE SPACES.
  16201. 056300     05  VR2-PLANT-CD1-ERR       PIC       X(7).
  16202. 056400     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16203. 056500     05  VR2-COMP-PCT1-ERR       PIC       XXX.
  16204. 056600     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16205. 056700     05  VR2-PLANT-CD2-ERR       PIC       X(7).
  16206. 056800     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16207. 056900     05  VR2-COMP-PCT2-ERR       PIC       XXX.
  16208. 057000     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16209. 057100     05  VR2-PLANT-CD3-ERR       PIC       X(7).
  16210. 057200     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16211. 057300     05  VR2-COMP-PCT3-ERR       PIC       XXX.
  16212. 057400     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16213. 057500     05  VR2-PLANT-CD4-ERR       PIC       X(7).
  16214. 057600     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16215. 057700     05  VR2-COMP-PCT4-ERR       PIC       XXX.
  16216. 057800     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16217. 057900 01  VR3-HDR-REC1.
  16218. 058000     05  FILLER                  PIC       X(6)      VALUE SPACES.
  16219. 058100     05  FILLER                  PIC       X(39)     VALUE
  16220. 058200         "LIN NUM      SOIL PHASE                ".
  16221. 058300     05  FILLER                  PIC       X(24)     VALUE
  16222. 058400         "SOIL NAME               ".
  16223. 058500     05  FILLER                  PIC       X(25)     VALUE
  16224. 058600         "SOIL PHASE               ".
  16225. 058700     05  FILLER                  PIC       X(9)      VALUE
  16226. 058800         "SOIL NAME".
  16227. 058900     05  FILLER                  PIC       X(29)     VALUE SPACES.
  16228. 059000 01  VR3-HDR-REC2.
  16229. 059100     05  FILLER                  PIC       X(7)      VALUE SPACES.
  16230. 059200     05  FILLER                  PIC       X(20)     VALUE
  16231. 059300         "31-34          35-39".
  16232. 059400     05  FILLER                  PIC       X(20)     VALUE SPACES.
  16233. 059500     05  FILLER                  PIC       X(5)      VALUE
  16234. 059600         "40-63".
  16235. 059700     05  FILLER                  PIC       X(20)     VALUE SPACES.
  16236. 059800     05  FILLER                  PIC       X(5)      VALUE
  16237. 059900         "64-68".
  16238. 060000     05  FILLER                  PIC      X(19)      VALUE SPACES.
  16239. 060100     05  FILLER                  PIC       X(5)      VALUE
  16240. 060200         "69-92".
  16241. 060300     05  FILLER                  PIC       X(31)     VALUE SPACES.
  16242. 060400 01  VR3-HDR-REC3.
  16243. 060500     05  FILLER                  PIC       X(8)      VALUE SPACES.
  16244. 060600     05  FILLER                  PIC       XXXX      VALUE "XXXX".
  16245. 060700     05  FILLER                  PIC       X(10)     VALUE SPACES.
  16246. 060800     05  FILLER                  PIC       X(5)      VALUE
  16247. 060900         "XXXXX".
  16248. 061000     05  FILLER                  PIC       X(12)     VALUE SPACES.
  16249. 061100     05  FILLER                  PIC       X(24)     VALUE
  16250. 061200         "XXXXXXXXXXXXXXXXXXXXXXXX".
  16251. 061300     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16252. 061400     05  FILLER                  PIC       X(5)      VALUE
  16253. 061500         "XXXXX".
  16254. 061600     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16255. 061700     05  FILLER                  PIC       X(24)     VALUE
  16256. 061800         "XXXXXXXXXXXXXXXXXXXXXXXX".
  16257. 061900     05  FILLER                  PIC       X(22)     VALUE SPACES.
  16258. 062000 01  VR3-HDR-DET-LN2.
  16259. 062100     05  FILLER                  PIC       X(8)      VALUE SPACES.
  16260. 062200     05  VR3-LIN-NUM-P           PIC       XXXX.
  16261. 062300     05  FILLER                  PIC       X(10)     VALUE SPACES.
  16262. 062400     05  VR3-SOIL-PHASE1-P       PIC       X(5).
  16263. 062500     05  FILLER                  PIC       X(10)     VALUE SPACES.
  16264. 062600     05  VR3-SOIL-NM1-P          PIC       X(24).
  16265. 062700     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16266. 062800     05  VR3-SOIL-PHASE2-P       PIC       X(5).
  16267. 062900     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16268. 063000     05  VR3-SOIL-NM2-P          PIC       X(24).
  16269. 063100     05  FILLER                  PIC       X(22)     VALUE SPACES.
  16270. 063200 01  VR3-HDR-ASTERISK-LN2.
  16271. 063300     05  FILLER                  PIC       X(8)      VALUE SPACES.
  16272. 063400     05  VR3-LIN-NUM-ERR         PIC       X(4).
  16273. 063500     05  FILLER                  PIC       X(10)     VALUE SPACES.
  16274. 063600     05  VR3-SOIL-PHASE1-ERR     PIC       X(5).
  16275. 063700     05  FILLER                  PIC       X(10)     VALUE SPACES.
  16276. 063800     05  VR3-SOIL-NM1-ERR        PIC       X(24).
  16277. 063900     05  FILLER                  PIC       X(11)     VALUE SPACES.
  16278. 064000     05  VR3-SOIL-PHASE2-ERR     PIC       X(5).
  16279. 064100     05  FILLER                  PIC       X(9)      VALUE SPACES.
  16280. 064200     05  VR3-SOIL-NM2-ERR        PIC       X(24).
  16281. 064300     05  FILLER                  PIC       X(22)     VALUE SPACES.
  16282. 064400 01 VR-VB-REC-HLD.
  16283. 064500     05  REC-TYP-HLD.
  16284. 064600         10  REC-TYP-VB1Z            PIC        XX.
  16285. 064700         10  FMT-NUM-VB1Z            PIC        X(1).
  16286. 064800         10  FORMAT-CD-VB1Z          PIC        X(1).
  16287. 064900     05  BLM-ADM-U-VB1Z.
  16288. 065000       07  SDR-VB1Z.
  16289. 065100         08  SD-VB1Z.
  16290. 065200           09  ADST-CD-VB1Z        PIC    XX.
  16291. 065300           09  DIST-CD-VB1Z        PIC    XX.
  16292. 065400         08  RA-CD-VB1Z               PIC    XX.
  16293. 065500       07  PU-CD-VB1Z              PIC    XX.
  16294. 065600     05  CLMTC-ADJ-FCTR-VB1Z     PIC        X(5).
  16295. 065700     05  DATA-DATE-VB1Z              PIC        X(6).
  16296. 065800     05  ACTION-CD-VB1Z              PIC        X(1).
  16297. 065900     05  LIN-NUM-VB1Z            PIC       X(4).
  16298. 066000     05  SWA-VB1Z.
  16299. 066100         10  SWA-CD-VB1Z          PIC      X.
  16300. 066200         10  SWA-NUM-VB1Z         PIC      X(3).
  16301. 066300     05  TRN-NUM-VB1Z            PIC       X(2).
  16302. 066400     05  SWA-PCT-VB1Z            PIC       X(3).
  16303. 066500     05  RNG-SITE-ID-VB1Z        PIC       X(11).
  16304. 066600     05  RNG-SITE-ID-VB1Z-RE REDEFINES RNG-SITE-ID-VB1Z.
  16305. 066700         10  RNG-SITE-ID-4-VB1Z  PIC      XXXX.
  16306. 066800         10  RNG-SITE-ID-3-VB1Z  PIC      XXX.
  16307. 066900         10  RNG-SITE-ID-ALL-VB1Z PIC     XXXX.
  16308. 067000     05  STRATUM-NUMER-VB1Z      PIC       X(4).
  16309. 067100     05  ALLOT-NUM-VB1Z          PIC       X(4).
  16310. 067200     05  PASTURE-NUM-VB1Z        PIC       X(2).
  16311. 067300     05  VEG-SUB-TYP-VB1Z        PIC       X(4).
  16312. 067400     05  RNG-ECOL-COND-CLS-VB1Z  PIC       X(1).
  16313. 067500     05  PCT-SLP-VB1Z            PIC       X(3).
  16314. 067600     05  ASPT-VB1Z               PIC       X(2).
  16315. 067700     05  L-FORM-VB1Z             PIC       X(3).
  16316. 067800     05  SOIL-PHAS-VB1Z          PIC       X(5).
  16317. 067900     05  FILLER                  PIC       X(19).
  16318. 068000 01  VR1-REC-HLD  REDEFINES VR-VB-REC-HLD.
  16319. 068100     05  GRP1-VR1Z.
  16320. 068200         10  REC-TYP-VR1Z        PIC       X(2).
  16321. 068300         10  FMT-NUM-VR1Z        PIC       X(1).
  16322. 068400         10  FORMAT-CD-VR1Z      PIC       X(1).
  16323. 068500     05  BLM-ADM-U-VR1Z.
  16324. 068600         10  ADST-CD-VR1Z        PIC       XX.
  16325. 068700         10  DIST-CD-VR1Z        PIC       XX.
  16326. 068800         10  RA-CD-VR1Z          PIC       XX.
  16327. 068900         10  PU-CD-VR1Z          PIC       XX.
  16328. 069000     05  DATA-DATE-VR1Z          PIC       X(6).
  16329. 069100     05  ACTION-CD-VR1Z          PIC       X(1).
  16330. 069200     05  RNG-SITE-ID-VR1Z        PIC       X(11).
  16331. 069300     05  RNG-SITE-ID-VR1Z-RE REDEFINES RNG-SITE-ID-VR1Z.
  16332. 069400         10  RNG-SITE-ID-4-VR1Z  PIC      XXXX.
  16333. 069500         10  RNG-SITE-ID-3-VR1Z  PIC      XXX.
  16334. 069600         10  RNG-SITE-ID-ALL-VR1Z PIC     XXXX.
  16335. 069700     05  LIN-NUM-VR1Z            PIC       X(4).
  16336. 069800     05  RNG-SITE-NAM-VR1Z       PIC       X(8).
  16337. 069900     05  PRECIP-ZONE-VR1Z        PIC       X(4).
  16338. 070000     05  SSF-VAL-AVG-VR1Z        PIC       X(3).
  16339. 070100     05  POTN-PPA-RS-VR1Z        PIC       X(6)  OCCURS 3 TIMES.
  16340. 070200     05  FILLER                  PIC       X(29).
  16341. 070300 01  VR2-REC-HLD  REDEFINES VR-VB-REC-HLD.
  16342. 070400     05  GRP1-VR2Z.
  16343. 070500         10  REC-TYP-VR2Z        PIC       X(2).
  16344. 070600         10  FMT-NUM-VR2Z        PIC       X(1).
  16345. 070700         10  FORMAT-CD-VR2Z      PIC       X(1).
  16346. 070800     05  BLM-ADM-U-VR2Z.
  16347. 070900         10  ADST-CD-VR2Z        PIC       XX.
  16348. 071000         10  DIST-CD-VR2Z        PIC       XX.
  16349. 071100         10  RA-CD-VR2Z          PIC       XX.
  16350. 071200         10  PU-CD-VR2Z          PIC       XX.
  16351. 071300     05  DATA-DATE-VR2Z          PIC       X(6).
  16352. 071400     05  ACTION-CD-VR2Z          PIC       X(1).
  16353. 071500     05  RNG-SITE-ID-VR2Z        PIC       X(11).
  16354. 071600     05  RNG-SITE-ID-VR2Z-RE REDEFINES RNG-SITE-ID-VR2Z.
  16355. 071700         10  RNG-SITE-ID-4-VR2Z  PIC      XXXX.
  16356. 071800         10  RNG-SITE-ID-3-VR2Z  PIC      XXX.
  16357. 071900         10  RNG-SITE-ID-ALL-VR2Z  PIC    XXXX.
  16358. 072000     05  LIN-NUM-VR2Z                 PIC       X(4).
  16359. 072100     05  GRP2-VR2Z  OCCURS 4 TIMES.
  16360. 072200         10  PLANT-CD-VR2Z       PIC       X(7).
  16361. 072300         10  PCT-COMP-VR2Z           PIC       XXX.
  16362. 072400     05  PLANT-TYP-VR2Z               PIC   X  OCCURS 4 TIMES.
  16363. 072500     05  FILLER                  PIC       X(18).
  16364. 072600 01  VR3-REC-HLD  REDEFINES VR-VB-REC-HLD.
  16365. 072700     05  GRP1-VR3Z.
  16366. 072800         10  REC-TYP-VR3Z        PIC       X(2).
  16367. 072900         10  FMT-NUM-VR3Z        PIC       X(1).
  16368. 073000         10  FORMAT-CD-VR3Z      PIC       X(1).
  16369. 073100     05  BLM-ADM-U-VR3Z.
  16370. 073200         10  ADST-CD-VR3Z        PIC      XX.
  16371. 073300         10  DIST-CD-VR3Z        PIC      XX.
  16372. 073400         10  RA-CD-VR3Z          PIC      XX.
  16373. 073500         10  PU-CD-VR3Z          PIC      XX.
  16374. 073600     05  DATA-DATE-VR3Z          PIC       X(6).
  16375. 073700     05  ACTION-CD-VR3Z          PIC       X(1).
  16376. 073800     05  RNG-SITE-ID-VR3Z        PIC       X(11).
  16377. 073900     05  RNG-SITE-ID-VR3Z-RE REDEFINES RNG-SITE-ID-VR3Z.
  16378. 074000         10  RNG-SITE-ID-4-VR3Z   PIC      XXXX.
  16379. 074100         10  RNG-SITE-ID-3-VR3Z   PIC      XXX.
  16380. 074200         10  RNG-SITE-ID-ALL-VR3Z PIC      XXXX.
  16381. 074300     05  LIN-NUM-VR3Z            PIC       X(4).
  16382. 074400     05  GRP2-VR3Z  OCCURS 2 TIMES.
  16383. 074500         10  SOIL-PHAS-VR3Z      PIC       X(5).
  16384. 074600         10  SOIL-NAM-VR3Z       PIC       X(24).
  16385. 074700     05  FILLER                   PIC      X(4).
  16386. 074800 01  VB-INST-ERR-LN1.
  16387. 074900     05  FILLER                  PIC       X(24)     VALUE SPACES.
  16388. 075000     05  FILLER                  PIC       X(46)     VALUE
  16389. 075100         "IF ERROR CORRECTION IS IN COMMON DATA (1-17), ".
  16390. 075200     05  FILLER                  PIC       X(38)     VALUE
  16391. 075300         "KEY ALL RECORDS WITH SAME COMMON DATA.".
  16392. 075400     05  FILLER                  PIC       X(24)     VALUE SPACES.
  16393. 075500 01  VB-INST-ERR-LN2.
  16394. 075600     05  FILLER                  PIC       X(24)     VALUE SPACES.
  16395. 075700     05  FILLER                  PIC       X(51)     VALUE
  16396. 075800         "IF ERROR CORRECTION IS IN FIELD POSITIONS (29-76), ".
  16397. 075900     05  FILLER                  PIC       X(36)     VALUE
  16398. 076000         "KEY (1-28) AND RED CORRECTED FIELDS.".
  16399. 076100     05  FILLER                  PIC       X(21)     VALUE SPACES.
  16400. 076200 01  VR-INST-ERR-LN1.
  16401. 076300     05  FILLER                  PIC       X(24)     VALUE SPACES.
  16402. 076400     05  FILLER                  PIC       X(62)     VALUE
  16403. 076500     "IF ERROR CORRECTION IS IN COMMON DATA (1-6 OR 20-30), KEY AL
  16404. 076600-         "L ".
  16405. 076700     05  FILLER                  PIC       X(30)     VALUE
  16406. 076800         "RECORDS WITH SAME COMMON DATA.".
  16407. 076900     05  FILLER                  PIC       X(16)     VALUE SPACES.
  16408. 077000 01  VR-INST-ERR-LN2.
  16409. 077100     05  FILLER                  PIC       X(24)     VALUE SPACES.
  16410. 077200     05  FILLER                  PIC       X(51)     VALUE
  16411. 077300         "IF ERROR CORRECTION IS IN FIELD POSITIONS (35-92), ".
  16412. 077400     05  FILLER                  PIC       X(36)     VALUE
  16413. 077500         "KEY (1-30) AND RED CORRECTED FIELDS.".
  16414. 077600     05  FILLER                  PIC       X(21)     VALUE SPACES.
  16415. 077700 01  DICTIONARY-SEPARATE.
  16416. 077800     05  DIC-NAM      PIC   X(23).
  16417. 077900     05  PLANT-TYP    PIC   X.
  16418. 078000 01  RANGE-SITE-ID.
  16419. 078100     05  MLRA              PIC   X(3).
  16420. 078200     05  RNG-NUM           PIC   X(8).
  16421. 078300     05  RNG-CHAR  REDEFINES RNG-NUM OCCURS 8 TIMES  PIC  X.
  16422. 078400 01  PRT-RESULT-TOT.
  16423. 078500     05  NO-ERRORS-P            PIC   X(35)   VALUE SPACES.
  16424. 078600     05  FILLER                 PIC   X(97)  VALUE SPACES.
  16425. 078700 01  PRT-RESULT-ERROR.
  16426. 078800     05  FILLER                 PIC   X(7)   VALUE
  16427. 078900          "INPUT  ".
  16428. 079000     05  INPUT-CTR-P            PIC   9(5).
  16429. 079100     05  FILLER                 PIC   X(6)   VALUE
  16430. 079200          "GOOD  ".
  16431. 079300     05  GOOD-CNTR-P            PIC   9(5).
  16432. 079400     05  FILLER                 PIC   X(5)   VALUE
  16433. 079500          "BAD  ".
  16434. 079600     05  BAD-CNTR-P             PIC   9(5).
  16435. 079700     05  FILLER                 PIC   X(99)   VALUE SPACES.
  16436. 079800 PROCEDURE DIVISION.
  16437. 079900 050-CONTROL SECTION.
  16438. 080000 100-CONTROL.
  16439. 080100     OPEN INPUT VR-VB-IN-FILE
  16440. 080200          OUTPUT VR-VB-OT-FILE
  16441. 080300          OUTPUT VM-WORK-FILE, VB-WORK-FILE
  16442. 080400          OUTPUT PRINTFILE.
  16443. 080500     READY DIC-DE.
  16444. 080600     MOVE 0 TO SWITCH-LINE1.
  16445. 080700     MOVE 0 TO ERR-FREE  RNGE-SITE-SAME.
  16446. 080800     MOVE SPACES TO VR-VB-REC-HLD, VR1-REC-HLD,
  16447. 080900          VR2-REC-HLD, VR3-REC-HLD,
  16448. 081000          VR-VB-OT-REC.
  16449. 081100     MOVE SPACES TO VB-ASTERISK-LN1  VB-ASTERISK-LN2
  16450. 081200          VR-HDR-ASTERISK-LN1  VR1-HDR-ASTERISK-LN2
  16451. 081300          VR2-HDR-ASTERISK-LN2  VR3-HDR-ASTERISK-LN2.
  16452. 081400     READ VR-VB-IN-FILE
  16453. 081500         AT END
  16454. 081600         MOVE 1 TO EOF-SWITCH.
  16455. 081700     IF  (REC-TYP-I1 = "VB1D") AND
  16456. 081800         (EOF-SWITCH = ZERO) AND
  16457. 081900        (RNG-ECOL-COND-CLS-I1 = " ")
  16458. 082000         MOVE "U" TO RNG-ECOL-COND-CLS-I1.
  16459. 082100     IF EOF-SWITCH = 0
  16460. 082200         MOVE VR-VB-IN-REC TO VR-VB-REC-HLD.
  16461. 082300     MOVE "ES320E" TO HDR-PCN.
  16462. 082400     ACCEPT AS-OF-DATE FROM DATE.  MOVE AS-OF-DA TO HDR-DD.
  16463. 082500     MOVE MON (AS-OF-MO) TO HDR-MMM.  MOVE AS-OF-YR TO HDR-YR.
  16464. 082600     IF  (REC-TYP-I1 = "VB1D") AND
  16465. 082700         (EOF-SWITCH = ZERO)
  16466. 082800         MOVE VR-VB-IN-REC TO VB-WORK-REC
  16467. 082900         WRITE VB-WORK-REC.
  16468. 083000     IF  REC-TYP-HLD = "VB1D"
  16469. 083100         MOVE REC-TYP-HLD TO REC-TYP-HLD-2
  16470. 083200         MOVE ADST-CD-VB1Z TO HLD-ST
  16471. 083300         MOVE DIST-CD-VB1Z TO HLD-DIST
  16472. 083400         MOVE RA-CD-VB1Z TO HLD-RA
  16473. 083500         MOVE PU-CD-VB1Z TO HLD-PU
  16474. 083600         MOVE CLMTC-ADJ-FCTR-VB1Z TO HLD-CLMTC-ADJ-FCTR
  16475. 083700         PERFORM 435-VALIDATE-ST THRU 490-EXIT
  16476. 083800         GO TO 130-CONT-PROCESS.
  16477. 083900     IF REC-TYP-HLD = "VR1D" OR "VR2D" OR "VR3D"
  16478. 084000        MOVE ADST-CD-VB1Z TO HLD-ST
  16479. 084100        MOVE REC-TYP-HLD TO REC-TYP-HLD-2
  16480. 084200        MOVE RNG-SITE-ID-VR2Z TO HLD-RNG-SITE-ID
  16481. 084300        PERFORM 432-VALIDATE-ST-VR THRU 434-EXIT
  16482. 084400        PERFORM 620A-CHK-RNGSITE THRU 621A-EXIT
  16483. 084500         PERFORM 415-CHK-TIT.
  16484. 084600     IF (REC-TYP-I1 = "VR1D") AND
  16485. 084700         (EOF-SWITCH = ZERO)
  16486. 084800         MOVE SPACE TO VM-WORK-REC
  16487. 084900         MOVE "VM1D" TO REC-TYP-U1
  16488. 085000         MOVE ADST-CD-VR1Z TO ST-U1
  16489. 085100         MOVE DIST-CD-VR1Z TO DS-U1
  16490. 085200         MOVE DATA-DATE-VR1Z TO DATE-U1
  16491. 085300         MOVE "A" TO ACT-U1
  16492. 085400         MOVE "2" TO STK-RATE-U1
  16493. 085500         MOVE RNG-SITE-ID-VR1Z TO RNG-SITE-U1
  16494. 085600         WRITE VM-WORK-REC.
  16495. 085700 130-CONT-PROCESS.
  16496. 085800     PERFORM 200-PROCESS THRU 250-READ-FL-AGAIN UNTIL EOF.
  16497. 085900     PERFORM 260-CHK-ERROR-CTR.
  16498. 086000     CLOSE VR-VB-IN-FILE
  16499. 086100           VR-VB-OT-FILE
  16500. 086200           VM-WORK-FILE
  16501. 086300           VB-WORK-FILE
  16502. 086400           PRINTFILE.
  16503. 086500     FINISH DIC-DE.
  16504. 086600     STOP RUN.
  16505. 086700 160-PRT-VB1D-HDNG.
  16506. 086800     ADD 1 TO PAGE-CTR.
  16507. 086900     MOVE PAGE-CTR TO HDR-PG.
  16508. 087000     WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
  16509. 087100     WRITE PRT-REC FROM HDR-2 AFTER ADVANCING 2 LINES.
  16510. 087200     WRITE PRT-REC FROM VB-INST-ERR-LN1 AFTER ADVANCING 2 LINES.
  16511. 087300     WRITE PRT-REC FROM VB-INST-ERR-LN2 AFTER ADVANCING 1 LINES.
  16512. 087400     MOVE 6 TO LINE-CTR.
  16513. 087500 200-PROCESS.
  16514. 087600 210-COMP-REC-TYP.
  16515. 087700     IF  REC-TYP-HLD-2 = REC-TYP-HLD GO TO 230-EQ-REC-TYP.
  16516. 087800     IF  REC-TYP-HLD = "VR1D"
  16517. 087900         MOVE 0 TO ERR-FREE  RNGE-SITE-SAME
  16518. 088000         MOVE 0 TO SWITCH-LINE1
  16519. 088100         MOVE REC-TYP-HLD TO REC-TYP-HLD-2
  16520. 088200         MOVE ADST-CD-VR1Z TO HLD-ST
  16521. 088300         MOVE RNG-SITE-ID-VR1Z TO HLD-RNG-SITE-ID
  16522. 088400         MOVE "VR1 EDIT ERROR LISTING" TO HDR-VR-TIT
  16523. 088500         MOVE SPACES TO VR-HDR-ASTERISK-LN1  VR1-HDR-ASTERISK-LN2
  16524. 088600         PERFORM 432-VALIDATE-ST-VR THRU 434-EXIT
  16525. 088700         PERFORM 522-CHK-RNGSITE THRU 526-EXIT
  16526. 088800         GO TO 230-EQ-REC-TYP.
  16527. 088900     IF  REC-TYP-HLD = "VR2D"
  16528. 089000         MOVE 0 TO ERR-FREE  RNGE-SITE-SAME
  16529. 089100         MOVE 0 TO SWITCH-LINE1
  16530. 089200         MOVE REC-TYP-HLD TO REC-TYP-HLD-2
  16531. 089300         MOVE ADST-CD-VR2Z TO HLD-ST
  16532. 089400         MOVE RNG-SITE-ID-VR2Z TO HLD-RNG-SITE-ID
  16533. 089500         MOVE "VR2 EDIT ERROR LISTING" TO HDR-VR-TIT
  16534. 089600         MOVE SPACES TO VR-HDR-ASTERISK-LN1  VR2-HDR-ASTERISK-LN2
  16535. 089700         PERFORM 432-VALIDATE-ST-VR THRU 434-EXIT
  16536. 089800         PERFORM 620A-CHK-RNGSITE THRU 621A-EXIT
  16537. 089900         GO TO 230-EQ-REC-TYP.
  16538. 090000     IF  REC-TYP-HLD = "VR3D"
  16539. 090100         MOVE 0 TO ERR-FREE  RNGE-SITE-SAME
  16540. 090200         MOVE 0 TO SWITCH-LINE1
  16541. 090300         MOVE REC-TYP-HLD TO REC-TYP-HLD-2
  16542. 090400         MOVE ADST-CD-VR3Z TO HLD-ST
  16543. 090500         MOVE RNG-SITE-ID-VR3Z TO HLD-RNG-SITE-ID
  16544. 090600         MOVE "VR3 EDIT ERROR LISTING" TO HDR-VR-TIT
  16545. 090700         MOVE SPACES TO VR-HDR-ASTERISK-LN1  VR3-HDR-ASTERISK-LN2
  16546. 090800         PERFORM 432-VALIDATE-ST-VR THRU 434-EXIT
  16547. 090900         PERFORM 710-CHK-RNGSITE THRU 735-EXIT
  16548. 091000         GO TO 230-EQ-REC-TYP.
  16549. 091100     IF  REC-TYP-HLD = "VB1D"
  16550. 091200         MOVE 0 TO SWITCH-LINE1
  16551. 091300         PERFORM 385-MV-TO-HLD
  16552. 091400         MOVE "VB  EDIT ERROR LISTING" TO HDR-VB-EDIT
  16553. 091500         MOVE SPACES TO VB-ASTERISK-LN1  VB-ASTERISK-LN2
  16554. 091600         PERFORM 435-VALIDATE-ST THRU 490-EXIT.
  16555. 091700 230-EQ-REC-TYP.
  16556. 091800     ADD 1 TO INPUT-CTR.
  16557. 091900     IF  REC-TYP-HLD-2 = "VB1D"
  16558. 092000         PERFORM 320-CHK-ST-VB THRU 384-EXIT-PRT
  16559. 092100         MOVE SPACES TO VB-ASTERISK-LN1  VB-ASTERISK-LN2
  16560. 092200         GO TO 250-READ-FL-AGAIN.
  16561. 092300     IF  REC-TYP-HLD-2 = "VR1D"
  16562. 092400          PERFORM 500-CHK-VR1D THRU 535-EXIT-PRT-VR1
  16563. 092500         IF (ERR-FREE = 1) AND (RNGE-SITE-SAME = 1)
  16564. 092600             MOVE SPACES TO VR2-HDR-ASTERISK-LN2
  16565. 092700             GO TO 250-READ-FL-AGAIN
  16566. 092800         ELSE
  16567. 092900             MOVE SPACES TO VR-HDR-ASTERISK-LN1
  16568. 093000               VR2-HDR-ASTERISK-LN2
  16569. 093100             GO TO 250-READ-FL-AGAIN.
  16570. 093200     IF REC-TYP-HLD-2 = "VR2D"
  16571. 093300         PERFORM 600-CHK-VR2D THRU 675-EXIT-PRT-VR2
  16572. 093400         IF (ERR-FREE = 1) AND (RNGE-SITE-SAME = 1)
  16573. 093500             MOVE SPACES TO VR2-HDR-ASTERISK-LN2
  16574. 093600             GO TO 250-READ-FL-AGAIN
  16575. 093700         ELSE
  16576. 093800             MOVE SPACES TO VR-HDR-ASTERISK-LN1
  16577. 093900               VR2-HDR-ASTERISK-LN2
  16578. 094000             GO TO 250-READ-FL-AGAIN.
  16579. 094100     IF  REC-TYP-HLD-2 = "VR3D"
  16580. 094200         PERFORM 700-CHK-VR3D THRU 785-EXIT-PRT-VR3
  16581. 094300         IF (ERR-FREE = 1) AND (RNGE-SITE-SAME = 1)
  16582. 094400             MOVE SPACES TO VR2-HDR-ASTERISK-LN2
  16583. 094500             GO TO 250-READ-FL-AGAIN
  16584. 094600         ELSE
  16585. 094700             MOVE SPACES TO VR-HDR-ASTERISK-LN1
  16586. 094800               VR2-HDR-ASTERISK-LN2
  16587. 094900             GO TO 250-READ-FL-AGAIN.
  16588. 095000     DISPLAY REC-TYP-HLD-2.
  16589. 095100     DISPLAY VR-VB-REC-HLD.
  16590. 095200 250-READ-FL-AGAIN.
  16591. 095300     READ VR-VB-IN-FILE
  16592. 095400         AT END
  16593. 095500         MOVE 1 TO EOF-SWITCH.
  16594. 095600     IF  (REC-TYP-I1 = "VB1D") AND
  16595. 095700         (EOF-SWITCH = ZERO) AND
  16596. 095800        (RNG-ECOL-COND-CLS-I1 = " ")
  16597. 095900         MOVE "U" TO RNG-ECOL-COND-CLS-I1.
  16598. 096000     IF EOF-SWITCH = 0
  16599. 096100         MOVE VR-VB-IN-REC TO VR-VB-REC-HLD.
  16600. 096200     IF  (REC-TYP-I1 = "VB1D") AND
  16601. 096300         (EOF-SWITCH = ZERO)
  16602. 096400         ADD 1 TO VB-IN-CNT
  16603. 096500         MOVE VR-VB-IN-REC TO VB-WORK-REC
  16604. 096600         WRITE VB-WORK-REC.
  16605. 096700     IF (REC-TYP-I1 = "VR1D") AND
  16606. 096800         (EOF-SWITCH = ZERO)
  16607. 096900         IF RNG-SITE-HLD = RNG-SITE-ID-VR1Z
  16608. 097000             NEXT SENTENCE ELSE
  16609. 097100             MOVE RNG-SITE-ID-VR1Z TO RNG-SITE-HLD
  16610. 097200             MOVE SPACE TO VM-WORK-REC
  16611. 097300             MOVE "VM1D" TO REC-TYP-U1
  16612. 097400             MOVE ADST-CD-VR1Z TO ST-U1
  16613. 097500             MOVE DIST-CD-VR1Z TO DS-U1
  16614. 097600             MOVE DATA-DATE-VR1Z TO DATE-U1
  16615. 097700             MOVE "A" TO ACT-U1
  16616. 097800             MOVE "2" TO STK-RATE-U1
  16617. 097900             MOVE RNG-SITE-ID-VR1Z TO RNG-SITE-U1
  16618. 098000             WRITE VM-WORK-REC.
  16619. 098100 260-CHK-ERROR-CTR.
  16620. 098200     IF  ERROR-CTR = ZERO
  16621. 098300         DISPLAY " NO ERRORS DETECTED ON THESE RECORDS"
  16622. 098400      ELSE
  16623. 098500        MOVE INPUT-CTR TO INPUT-CTR-P
  16624. 098600        MOVE GOOD-CTR TO GOOD-CNTR-P
  16625. 098700        MOVE ERROR-CTR TO BAD-CNTR-P
  16626. 098800        WRITE PRT-REC FROM PRT-RESULT-ERROR AFTER ADVANCING
  16627. 098900                                            2 LINES
  16628. 099000        ADD 2 TO LINE-CTR.
  16629. 099100 275-WRT-HDR-ST.
  16630. 099200     WRITE PRT-REC FROM VR-INST-ERR-LN1 AFTER ADVANCING 2 LINES.
  16631. 099300     WRITE PRT-REC FROM VR-INST-ERR-LN2 AFTER ADVANCING 1 LINES.
  16632. 099400     ADD 3 TO LINE-CTR.
  16633. 099500 320-CHK-ST-VB.
  16634. 099600     IF  HLD-ST = ADST-CD-VB1Z NEXT SENTENCE
  16635. 099700     ELSE
  16636. 099800         PERFORM 435-VALIDATE-ST THRU 490-EXIT
  16637. 099900         MOVE 0 TO PAGE-CTR
  16638. 100000         PERFORM 430-PRT-HEADING2
  16639. 100100         MOVE 0 TO SWITCH-LINE1
  16640. 100200         PERFORM 385-MV-TO-HLD
  16641. 100300         GO TO 370-EDIT-VB1D.
  16642. 100400 330-CHK-DIST-VB.
  16643. 100500     IF HLD-DIST = DIST-CD-VB1Z NEXT SENTENCE
  16644. 100600     ELSE
  16645. 100700         PERFORM 435-VALIDATE-ST THRU 490-EXIT
  16646. 100800         MOVE 0 TO PAGE-CTR
  16647. 100900         PERFORM 430-PRT-HEADING2
  16648. 101000         MOVE 0 TO SWITCH-LINE1
  16649. 101100         PERFORM 385-MV-TO-HLD
  16650. 101200         GO TO 370-EDIT-VB1D.
  16651. 101300 340-CHK-RA-VB.
  16652. 101400     IF HLD-RA = RA-CD-VB1Z NEXT SENTENCE
  16653. 101500     ELSE
  16654. 101600         PERFORM 435-VALIDATE-ST THRU 490-EXIT
  16655. 101700         MOVE 0 TO SWITCH-LINE1
  16656. 101800         PERFORM 385-MV-TO-HLD
  16657. 101900         GO TO 370-EDIT-VB1D.
  16658. 102000 350-CHK-PU-VB.
  16659. 102100     IF HLD-PU = PU-CD-VB1Z NEXT SENTENCE
  16660. 102200     ELSE
  16661. 102300         PERFORM 435-VALIDATE-ST THRU 490-EXIT
  16662. 102400         MOVE 0 TO SWITCH-LINE1
  16663. 102500         PERFORM 385-MV-TO-HLD
  16664. 102600         GO TO 370-EDIT-VB1D.
  16665. 102700 360-CHK-CLMTC-ADJ-FCTR.
  16666. 102800     IF  HLD-CLMTC-ADJ-FCTR = CLMTC-ADJ-FCTR-VB1Z NEXT SENTENCE
  16667. 102900     ELSE
  16668. 103000         MOVE 0 TO SWITCH-LINE1
  16669. 103100         PERFORM 385-MV-TO-HLD.
  16670. 103200 370-EDIT-VB1D.
  16671. 103300     IF REC-TYP-HLD-2 NOT = "VB1D"
  16672. 103400        MOVE ALL "*" TO REC-TYP-ERR.
  16673. 103500     IF HLD-CLMTC-ADJ-FCTR NOT NUMERIC
  16674. 103600       OR  HLD-CLMTC-ADJ-FCTR NOT > ZERO
  16675. 103700         MOVE ALL "*" TO CLIMATIC-ADJ-ERR.
  16676. 103800     IF ACTION-CD-VB1Z NOT = "A" AND "D"
  16677. 103900        MOVE "*" TO ACTN-ERR.
  16678. 104000     IF SWA-CD-VB1Z NOT ALPHABETIC
  16679. 104100         OR SWA-CD-VB1Z = SPACE
  16680. 104200             MOVE ALL "*" TO VB-SWA-ERR.
  16681. 104300     IF SWA-NUM-VB1Z NOT NUMERIC
  16682. 104400         IF SWA-NUM-VB1Z = SPACES
  16683. 104500             MOVE ZEROS TO SWA-NUM-VB1Z
  16684. 104600         ELSE
  16685. 104700             MOVE ALL "*" TO VB-SWA-ERR.
  16686. 104800     IF TRN-NUM-VB1Z NOT NUMERIC
  16687. 104900         IF TRN-NUM-VB1Z = SPACES
  16688. 105000             MOVE ZEROS TO TRN-NUM-VB1Z
  16689. 105100         ELSE
  16690. 105200             MOVE ALL "*" TO VB-TRNSCT-ERR.
  16691. 105300     IF SWA-PCT-VB1Z LESS THAN "001" OR
  16692. 105400        SWA-PCT-VB1Z GREATER THAN "100"
  16693. 105500         MOVE ALL "*" TO VB-PCT-SWA-ERR.
  16694. 105600     IF STRATUM-NUMER-VB1Z NOT NUMERIC OR
  16695. 105700       STRATUM-NUMER-VB1Z NOT GREATER THAN ZERO
  16696. 105800             MOVE ALL "*" TO VB-STRTUM-ERR.
  16697. 105900     IF RNG-SITE-ID-VB1Z = SPACES OR ZEROS
  16698. 106000         MOVE ALL "*" TO VB-RNGE-SITE-ERR.
  16699. 106100     EXAMINE RNG-SITE-ID-VB1Z TALLYING UNTIL FIRST SPACE.
  16700. 106200     MOVE TALLY TO RNG-SITE-TALLY.
  16701. 106300     EXAMINE RNG-SITE-ID-VB1Z TALLYING ALL SPACES.
  16702. 106400     ADD TALLY TO RNG-SITE-TALLY.
  16703. 106500     IF RNG-SITE-TALLY NOT = 11
  16704. 106600         MOVE ALL "*" TO VB-RNGE-SITE-ERR.
  16705. 106700     IF RNG-SITE-ID-4-VB1Z = "G58C" OR "G59C"
  16706. 106800         GO TO 370B-CHK-RNGSITE-VB1D.
  16707. 106900     MOVE RNG-SITE-ID-4-VB1Z TO DE-CD-8822-DEC.
  16708. 107000     MOVE "3902" TO DE-NO-8801-DEC.
  16709. 107100     FIND ANY CODE-DEC.
  16710. 107200     MOVE DB-STATUS TO DB-STAT.
  16711. 107300     IF NOT OK
  16712. 107400         MOVE ALL "*" TO VB-RNGSITE-ERR-4.
  16713. 107500 370B-CHK-RNGSITE-VB1D.
  16714. 107600     IF RNG-SITE-ID-3-VB1Z NOT NUMERIC
  16715. 107700         MOVE ALL "*" TO VB-RNGSITE-ERR-3.
  16716. 107800     IF ALLOT-NUM-VB1Z
  16717. 107900         NOT NUMERIC
  16718. 108000             MOVE ALL "*" TO VB-ALLOT-ERR.
  16719. 108100     IF PASTURE-NUM-VB1Z NOT NUMERIC
  16720. 108200         IF PASTURE-NUM-VB1Z = SPACES
  16721. 108300             MOVE ZEROS TO PASTURE-NUM-VB1Z
  16722. 108400         ELSE
  16723. 108500             MOVE ALL "*" TO VB-PASTURE-ERR.
  16724. 108600 371-CHK-VEG.
  16725. 108700     IF VEG-SUB-TYP-VB1Z = SPACES GO TO 372-CHK-COND-CLS.
  16726. 108800     MOVE VEG-SUB-TYP-VB1Z TO DE-CD-8822-DEC.
  16727. 108900     MOVE 2706 TO DE-NO-8801-DEC.
  16728. 109000     FIND ANY CODE-DEC.
  16729. 109100     MOVE DB-STATUS TO DB-STAT.
  16730. 109200     IF NOT OK
  16731. 109300        MOVE ALL "*" TO VB-VEG-SUB-ERR.
  16732. 109400 372-CHK-COND-CLS.
  16733. 109500     IF RNG-ECOL-COND-CLS-VB1Z = " "
  16734. 109600         MOVE "U" TO RNG-ECOL-COND-CLS-VB1Z.
  16735. 109700     IF BLM-ADM-U-VB1Z NOT = "CA026804" NEXT SENTENCE
  16736. 109800     ELSE IF RNG-ECOL-COND-CLS-VB1Z = "S" OR "M" OR "D"
  16737. 109900         GO TO 373-CHK-PCT-SLP.
  16738. 110000     IF RNG-ECOL-COND-CLS-VB1Z NOT =
  16739. 110100         "E" AND "F" AND "G" AND "P" AND "U"
  16740. 110200             MOVE "*" TO VB-COND-CL-ERR.
  16741. 110300 373-CHK-PCT-SLP.
  16742. 110400     IF PCT-SLP-VB1Z = SPACES GO TO 374-CHK-ASPT.
  16743. 110500     IF  PCT-SLP-VB1Z NOT NUMERIC
  16744. 110600         MOVE ZEROS TO PCT-SLP-VB1Z
  16745. 110700         MOVE ALL "*" TO VB-PCT-SLOPE-ERR.
  16746. 110800 374-CHK-ASPT.
  16747. 110900     IF ASPT-VB1Z = SPACES GO TO 374A-CHK-L-FORM.
  16748. 111000     MOVE ASPT-VB1Z TO DE-CD-8822-DEC.
  16749. 111100     MOVE 6523 TO DE-NO-8801-DEC.
  16750. 111200     FIND ANY CODE-DEC.
  16751. 111300     IF NOT OK
  16752. 111400         MOVE ALL "*" TO VB-SLOPE-ASP-ERR.
  16753. 111500 374A-CHK-L-FORM.
  16754. 111600     IF L-FORM-VB1Z = SPACES GO TO 380-EXIT.
  16755. 111700     MOVE L-FORM-VB1Z TO DE-CD-8822-DEC.
  16756. 111800     MOVE 5132 TO DE-NO-8801-DEC.
  16757. 111900     FIND ANY CODE-DEC.
  16758. 112000     MOVE DB-STATUS TO DB-STAT.
  16759. 112100     IF NOT OK
  16760. 112200        MOVE ALL "*" TO VB-LAND-FORM-ERR.
  16761. 112300 380-EXIT.
  16762. 112400     EXIT.
  16763. 112500 382-CHK-TWO-LINES.
  16764. 112600     IF  VB-ASTERISK-LN1 = SPACES AND
  16765. 112700         VB-ASTERISK-LN2 = SPACES
  16766. 112800         WRITE VR-VB-OT-REC FROM VR-VB-REC-HLD
  16767. 112900         ADD 1 TO GOOD-CTR
  16768. 113000         GO TO 384-EXIT-PRT.
  16769. 113100     ADD 1 TO ERROR-CTR.
  16770. 113200     IF  SWITCH-LINE1 = 1
  16771. 113300         PERFORM 400-WRITE-ERROR-VB
  16772. 113400         GO TO 384-EXIT-PRT
  16773. 113500     ELSE
  16774. 113600         MOVE 1 TO SWITCH-LINE1
  16775. 113700         PERFORM 160-PRT-VB1D-HDNG
  16776. 113800         PERFORM 390-MV-HDR-DET1
  16777. 113900         WRITE PRT-REC FROM VB-HDR-REC1 AFTER ADVANCING 2 LINES.
  16778. 114000         WRITE PRT-REC FROM VB-HDR-REC2 AFTER ADVANCING 1 LINES.
  16779. 114100         WRITE PRT-REC FROM VB-HDR-REC3 AFTER ADVANCING 1 LINES.
  16780. 114200         WRITE PRT-REC FROM VB-DET-LN1 AFTER ADVANCING 2 LINES.
  16781. 114300         WRITE PRT-REC FROM VB-ASTERISK-LN1 AFTER ADVANCING
  16782. 114400                                                  2 LINES.
  16783. 114500         WRITE PRT-REC FROM VB-HDR-REC4 AFTER ADVANCING 2 LINES.
  16784. 114600         WRITE PRT-REC FROM VB-HDR-REC5 AFTER ADVANCING 1 LINES.
  16785. 114700         WRITE PRT-REC FROM VB-HDR-REC6 AFTER ADVANCING 1 LINES.
  16786. 114800         ADD 12 TO LINE-CTR.
  16787. 114900         PERFORM 400-WRITE-ERROR-VB.
  16788. 115000 384-EXIT-PRT.
  16789. 115100     EXIT.
  16790. 115200 385-MV-TO-HLD.
  16791. 115300     MOVE REC-TYP-HLD TO REC-TYP-HLD-2.
  16792. 115400     MOVE ADST-CD-VB1Z TO HLD-ST.
  16793. 115500     MOVE DIST-CD-VB1Z TO HLD-DIST.
  16794. 115600     MOVE RA-CD-VB1Z TO HLD-RA.
  16795. 115700     MOVE PU-CD-VB1Z TO HLD-PU.
  16796. 115800     MOVE CLMTC-ADJ-FCTR-VB1Z TO HLD-CLMTC-ADJ-FCTR.
  16797. 115900 390-MV-HDR-DET1.
  16798. 116000     MOVE SPACES TO VB-DET-LN1.
  16799. 116100     MOVE REC-TYP-HLD-2 TO REC-TYP-P.
  16800. 116200     MOVE HLD-ST TO ST-P.
  16801. 116300     MOVE HLD-DIST TO DIST-P.
  16802. 116400     MOVE HLD-RA TO RS-P.
  16803. 116500     MOVE HLD-PU TO PU-P.
  16804. 116600     MOVE HLD-CLMTC-ADJ-FCTR TO CLIMATIC-ADJ-P.
  16805. 116700     MOVE DATA-DATE-VB1Z TO DATE-P.
  16806. 116800     MOVE ACTION-CD-VB1Z TO ACTN-P.
  16807. 116900 400-WRITE-ERROR-VB.
  16808. 117000     MOVE SPACES TO VB-DET-LN2.
  16809. 117100     IF LINE-CTR > 50
  16810. 117200         PERFORM 160-PRT-VB1D-HDNG
  16811. 117300         WRITE PRT-REC FROM VB-HDR-REC4 AFTER ADVANCING 2 LINES
  16812. 117400         WRITE PRT-REC FROM VB-HDR-REC5 AFTER ADVANCING 1 LINES
  16813. 117500         WRITE PRT-REC FROM VB-HDR-REC6 AFTER ADVANCING 1 LINES
  16814. 117600         ADD 4 TO LINE-CTR.
  16815. 117700     MOVE LIN-NUM-VB1Z TO VB-LIN-NUM-P.
  16816. 117800     MOVE SWA-VB1Z TO VB-SWA-P.
  16817. 117900     MOVE TRN-NUM-VB1Z TO VB-TRN-P.
  16818. 118000     MOVE SWA-PCT-VB1Z TO VB-PCT-SWA-P.
  16819. 118100     MOVE RNG-SITE-ID-VB1Z TO VB-RNGE-SITE-P.
  16820. 118200     MOVE STRATUM-NUMER-VB1Z TO VB-STRTUM-P.
  16821. 118300     MOVE ALLOT-NUM-VB1Z TO VB-ALLOT-P.
  16822. 118400     MOVE PASTURE-NUM-VB1Z TO VB-PASTURE-P.
  16823. 118500     MOVE VEG-SUB-TYP-VB1Z TO VB-VEG-SUB-P.
  16824. 118600     MOVE RNG-ECOL-COND-CLS-VB1Z TO VB-COND-CL-P.
  16825. 118700     MOVE PCT-SLP-VB1Z TO VB-PCT-SLOPE-P.
  16826. 118800     MOVE ASPT-VB1Z TO VB-SLOPE-ASP-P.
  16827. 118900     MOVE L-FORM-VB1Z TO VB-LAND-FORM-P.
  16828. 119000     MOVE SOIL-PHAS-VB1Z TO VB-SOIL-PHASE-P.
  16829. 119100     WRITE PRT-REC FROM VB-DET-LN2 AFTER ADVANCING 2 LINES.
  16830. 119200     WRITE PRT-REC FROM VB-ASTERISK-LN2 AFTER ADVANCING 1 LINES.
  16831. 119300     ADD 3 TO LINE-CTR.
  16832. 119400 415-CHK-TIT.
  16833. 119500     MOVE RNG-SITE-ID-VR1Z TO HLD-RNG-SITE-ID.
  16834. 119600     IF  REC-TYP-HLD = "VR1D"
  16835. 119700         MOVE "VR1 EDIT ERROR LISTING" TO HDR-VR-TIT
  16836. 119800     ELSE
  16837. 119900         IF REC-TYP-HLD = "VR2D"
  16838. 120000             MOVE "VR2 EDIT ERROR LISTING" TO HDR-VR-TIT
  16839. 120100         ELSE
  16840. 120200           IF  REC-TYP-HLD = "VR3D"
  16841. 120300              MOVE "VR3-EDIT ERROR LISTING" TO HDR-VR-TIT.
  16842. 120400 420-HEADING-ROUTINE.
  16843. 120500     MOVE 1 TO PAGE-CTR.
  16844. 120600     MOVE PAGE-CTR TO HDR-PG.
  16845. 120700     WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
  16846. 120800     WRITE PRT-REC FROM VR-HDR-ST AFTER ADVANCING 2 LINES
  16847. 120900     MOVE 3 TO LINE-CTR.
  16848. 121000 430-PRT-HEADING2.
  16849. 121100     ADD 1 TO PAGE-CTR.
  16850. 121200     MOVE PAGE-CTR TO HDR-PG.
  16851. 121300     WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
  16852. 121400     WRITE PRT-REC FROM VR-HDR-ST AFTER ADVANCING 2 LINES.
  16853. 121500     MOVE 3 TO LINE-CTR.
  16854. 121600 432-VALIDATE-ST-VR.
  16855. 121700     MOVE ADST-CD-VR1Z TO DE-CD-8822-DEC.
  16856. 121800     MOVE 0003 TO DE-NO-8801-DEC.
  16857. 121900     FIND ANY CODE-DEC.
  16858. 122000     MOVE DB-STATUS TO DB-STAT.
  16859. 122100     IF NOT OK
  16860. 122200         MOVE "UNKNOWN" TO HDR-VR-ST
  16861. 122300         GO TO 434-EXIT.
  16862. 122400     GET CODE-DEC.
  16863. 122500     MOVE DB-STATUS TO DB-STAT.
  16864. 122600     IF NOT  OK
  16865. 122700         DISPLAY "DIDN'T GET ST"
  16866. 122800         DISPLAY DB-STAT
  16867. 122900         GO TO 434-EXIT.
  16868. 123000     MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
  16869. 123100     MOVE ST-NM-HLD TO HDR-VR-ST.
  16870. 123200 434-EXIT.
  16871. 123300     EXIT.
  16872. 123400 435-VALIDATE-ST.
  16873. 123500     MOVE ADST-CD-VB1Z TO DE-CD-8822-DEC.
  16874. 123600 436-MV-ST.
  16875. 123700     MOVE 0003 TO DE-NO-8801-DEC.
  16876. 123800     FIND ANY CODE-DEC.
  16877. 123900     MOVE DB-STATUS TO DB-STAT.
  16878. 124000     IF NOT OK
  16879. 124100         PERFORM 440-ST-NOT-FND
  16880. 124200         GO  TO 490-EXIT.
  16881. 124300     GET CODE-DEC.
  16882. 124400     MOVE DB-STATUS TO DB-STAT.
  16883. 124500     IF NOT  OK
  16884. 124600         PERFORM 440-ST-NOT-FND
  16885. 124700        GO  TO 490-EXIT.
  16886. 124800     MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
  16887. 124900     MOVE ST-NM-HLD TO HDR-ST-NM.
  16888. 125000 437-VALIDATE-ST-DIST.
  16889. 125100     MOVE SD-VB1Z TO DE-CD-8822-DEC.
  16890. 125200     MOVE 0003 TO DE-NO-8801-DEC.
  16891. 125300     FIND ANY CODE-DEC.
  16892. 125400     MOVE DB-STATUS TO DB-STAT.
  16893. 125500     IF NOT OK
  16894. 125600        PERFORM 450-SD-NOT-FND
  16895. 125700        GO  TO 490-EXIT.
  16896. 125800     GET CODE-DEC.
  16897. 125900     MOVE DB-STATUS TO DB-STAT.
  16898. 126000     IF NOT OK
  16899. 126100         PERFORM 450-SD-NOT-FND
  16900. 126200         GO TO 490-EXIT.
  16901. 126300     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  16902. 126400     MOVE DB-STATUS TO DB-STAT.
  16903. 126500     IF  NOT OK
  16904. 126600         PERFORM 450-SD-NOT-FND
  16905. 126700         GO  TO 490-EXIT.
  16906. 126800     GET CODE-EXPL-DECE.
  16907. 126900     MOVE DB-STATUS TO DB-STAT.
  16908. 127000     IF NOT OK
  16909. 127100         PERFORM 450-SD-NOT-FND
  16910. 127200         GO  TO 490-EXIT.
  16911. 127300     MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD.
  16912. 127400     MOVE DIST-NM-HLD TO HDR-DIST-NM.
  16913. 127500 438-VALIDATE-SDR.
  16914. 127600     MOVE SDR-VB1Z TO DE-CD-8822-DEC.
  16915. 127700     MOVE 0003 TO DE-NO-8801-DEC.
  16916. 127800     FIND ANY CODE-DEC.
  16917. 127900     MOVE DB-STATUS TO DB-STAT.
  16918. 128000     IF  NOT OK
  16919. 128100         PERFORM 470-SDR-NOT-FND
  16920. 128200         GO  TO 490-EXIT.
  16921. 128300 439-VALIDATE-SDRP.
  16922. 128400     MOVE BLM-ADM-U-VB1Z TO DE-CD-8822-DEC.
  16923. 128500     MOVE 0003 TO DE-NO-8801-DEC.
  16924. 128600     FIND ANY CODE-DEC.
  16925. 128700     MOVE DB-STATUS TO DB-STAT.
  16926. 128800     IF NOT OK
  16927. 128900         PERFORM 480-SDRP-NOT-FND
  16928. 129000         GO TO 490-EXIT.
  16929. 129100     GO TO 490-EXIT.
  16930. 129200 440-ST-NOT-FND.
  16931. 129300     MOVE "UNKNOWN" TO HDR-ST-NM  HDR-DIST-NM.
  16932. 129400     MOVE ALL "*" TO ST-ERR  DIST-ERR  RS-ERR  PU-ERR.
  16933. 129500 450-SD-NOT-FND.
  16934. 129600     MOVE "UNKNOWN" TO HDR-DIST-NM.
  16935. 129700     MOVE ALL "*" TO DIST-ERR  RS-ERR  PU-ERR.
  16936. 129800 470-SDR-NOT-FND.
  16937. 129900     MOVE ALL "*" TO RS-ERR  PU-ERR.
  16938. 130000 480-SDRP-NOT-FND.
  16939. 130100     MOVE ALL "*" TO PU-ERR.
  16940. 130200 490-EXIT.
  16941. 130300     EXIT.
  16942. 130400 500-CHK-VR1D.
  16943. 130500     IF  HLD-RNG-SITE-ID = RNG-SITE-ID-VR1Z NEXT SENTENCE
  16944. 130600     ELSE
  16945. 130700         MOVE 0 TO RNGE-SITE-SAME
  16946. 130800         MOVE SPACES TO HDR-VR-RNG-SITE-NO-ERR
  16947. 130900         MOVE "VR1 EDIT ERROR LISTING" TO HDR-VR-TIT
  16948. 131000         MOVE 0 TO SWITCH-LINE1
  16949. 131100         MOVE ADST-CD-VR1Z TO HLD-ST
  16950. 131200         MOVE REC-TYP-HLD TO REC-TYP-HLD-2
  16951. 131300         MOVE RNG-SITE-ID-VR1Z TO HLD-RNG-SITE-ID
  16952. 131400         PERFORM 522-CHK-RNGSITE THRU 526-EXIT
  16953. 131500         PERFORM 550-PRT-HDNG-VR
  16954. 131600         GO TO 520-EDIT-VR1D.
  16955. 131700     MOVE 1 TO RNGE-SITE-SAME.
  16956. 131800     IF  HLD-ST = ADST-CD-VR1Z NEXT SENTENCE
  16957. 131900     ELSE
  16958. 132000         MOVE 1 TO PAGE-CTR
  16959. 132100         MOVE "VR1 EDIT ERROR LISTING" TO HDR-VR-TIT
  16960. 132200         MOVE 0 TO SWITCH-LINE1
  16961. 132300         MOVE ADST-CD-VR1Z TO HLD-ST
  16962. 132400         MOVE REC-TYP-HLD TO REC-TYP-HLD-2
  16963. 132500         PERFORM 550-PRT-HDNG-VR.
  16964. 132600 520-EDIT-VR1D.
  16965. 132700     IF REC-TYP-HLD-2 NOT = "VR1D"
  16966. 132800         MOVE ALL "*" TO HDR-VR-REC-TYP-ERR.
  16967. 132900     IF  ACTION-CD-VR1Z NOT = "A" AND "D"
  16968. 133000         MOVE "*" TO HDR-VR-ACTN-ERR
  16969. 133100         GO TO 527-CHK-PRECIP.
  16970. 133200 522-CHK-RNGSITE.
  16971. 133300     IF RNG-SITE-ID-VR1Z = ZERO OR
  16972. 133400         RNG-SITE-ID-VR1Z = SPACE
  16973. 133500         MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
  16974. 133600     MOVE RNG-SITE-ID-VR1Z TO RANGE-SITE-ID.
  16975. 133700     EXAMINE MLRA TALLYING ALL SPACE.
  16976. 133800     IF TALLY > ZERO
  16977. 133900         MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
  16978. 134000     MOVE 8 TO I.
  16979. 134100     PERFORM 580-EXAMINE-ID UNTIL I < 1 OR RNG-CHAR (I)
  16980. 134200         NOT = SPACE.
  16981. 134300     EXAMINE RNG-NUM TALLYING UNTIL FIRST SPACE.
  16982. 134400     IF I > 0
  16983. 134500         IF TALLY NOT = I
  16984. 134600             MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
  16985. 134700     IF RNG-SITE-ID-4-VR1Z = "G58C" OR "G59C"
  16986. 134800         GO TO 525-CHK-RNG-SITE-VR1Z.
  16987. 134900     MOVE RNG-SITE-ID-4-VR1Z TO DE-CD-8822-DEC.
  16988. 135000     MOVE "3902" TO DE-NO-8801-DEC.
  16989. 135100     FIND ANY CODE-DEC.
  16990. 135200     MOVE DB-STATUS TO DB-STAT.
  16991. 135300     IF NOT OK
  16992. 135400         MOVE ALL "*" TO VR-RNGSITE-ERR-4.
  16993. 135500 525-CHK-RNG-SITE-VR1Z.
  16994. 135600     IF RNG-SITE-ID-3-VR1Z NOT NUMERIC
  16995. 135700         MOVE ALL "*" TO VR-RNGSITE-ERR-3.
  16996. 135800 526-EXIT.
  16997. 135900     EXIT.
  16998. 136000 527-CHK-PRECIP.
  16999. 136100     IF PRECIP-ZONE-VR1Z NOT NUMERIC
  17000. 136200         AND PRECIP-ZONE-VR1Z NOT = SPACE
  17001. 136300         MOVE ALL "*" TO VR1-PRECIP-ERR.
  17002. 136400     IF PRECIP-ZONE-VR1Z = SPACE
  17003. 136500         MOVE ZERO TO PRECIP-ZONE-VR1Z.
  17004. 136600     IF SSF-VAL-AVG-VR1Z = SPACE
  17005. 136700         MOVE ZERO TO SSF-VAL-AVG-VR1Z.
  17006. 136800     IF SSF-VAL-AVG-VR1Z NOT NUMERIC
  17007. 136900         AND SSF-VAL-AVG-VR1Z NOT = SPACE
  17008. 137000         MOVE ALL "*" TO VR1-SOIL-SURF-ERR.
  17009. 137100     IF POTN-PPA-RS-VR1Z (1) = SPACE
  17010. 137200         MOVE ALL "*" TO VR1-AVG-YR-ERR.
  17011. 137300     IF  POTN-PPA-RS-VR1Z (1) NOT NUMERIC
  17012. 137400         OR POTN-PPA-RS-VR1Z (1) = ZERO
  17013. 137500         MOVE ALL "*" TO VR1-AVG-YR-ERR.
  17014. 137600     IF POTN-PPA-RS-VR1Z (2) = SPACE
  17015. 137700         MOVE ALL "*" TO VR1-FAVORABLE-YR-ERR.
  17016. 137800     IF  POTN-PPA-RS-VR1Z (2) NOT NUMERIC
  17017. 137900         OR POTN-PPA-RS-VR1Z (2) = ZERO
  17018. 138000         MOVE ALL "*" TO VR1-FAVORABLE-YR-ERR.
  17019. 138100     IF  POTN-PPA-RS-VR1Z (3) = SPACE
  17020. 138200         MOVE ALL "*" TO VR1-UNFAVORABLE-YR-ERR.
  17021. 138300     IF  POTN-PPA-RS-VR1Z (3) NOT NUMERIC
  17022. 138400         OR POTN-PPA-RS-VR1Z (3) = ZERO
  17023. 138500         MOVE ALL "*" TO VR1-UNFAVORABLE-YR-ERR.
  17024. 138600 530-CHK-VR-ERR.
  17025. 138700     IF  VR-HDR-ASTERISK-LN1 = SPACES AND
  17026. 138800         VR1-HDR-ASTERISK-LN2 = SPACES
  17027. 138900         WRITE VR-VB-OT-REC FROM VR1-REC-HLD
  17028. 139000         ADD 1 TO GOOD-CTR
  17029. 139100         GO TO 535-EXIT-PRT-VR1.
  17030. 139200     MOVE 1 TO ERR-FREE.
  17031. 139300     ADD 1 TO ERROR-CTR.
  17032. 139400     IF  SWITCH-LINE1 = 1
  17033. 139500         PERFORM 590-WRT-ERROR-VR1
  17034. 139600         GO TO 535-EXIT-PRT-VR1
  17035. 139700     ELSE
  17036. 139800         MOVE 1 TO SWITCH-LINE1
  17037. 139900         PERFORM 560-PRT-HDNG
  17038. 140000         PERFORM 275-WRT-HDR-ST
  17039. 140100         PERFORM 585-MV-HDR-DET-VR
  17040. 140200         WRITE PRT-REC FROM VR-HDR-REC1 AFTER ADVANCING 2 LINES.
  17041. 140300         WRITE PRT-REC FROM VR-HDR-REC2 AFTER ADVANCING 1 LINES.
  17042. 140400         WRITE PRT-REC FROM VR-HDR-REC3 AFTER ADVANCING 1 LINES.
  17043. 140500         WRITE PRT-REC FROM VR-HDR-DET-LN1 AFTER ADVANCING
  17044. 140600                                                 2 LINES.
  17045. 140700         WRITE PRT-REC FROM VR-HDR-ASTERISK-LN1 AFTER ADVANCING 1
  17046. 140800                                                      LINES.
  17047. 140900         WRITE PRT-REC FROM VR1-HDR-REC1 AFTER ADVANCING 2 LINES.
  17048. 141000         WRITE PRT-REC FROM VR1-HDR-REC2 AFTER ADVANCING 1 LINES.
  17049. 141100         WRITE PRT-REC FROM VR1-HDR-REC3 AFTER ADVANCING 1 LINES.
  17050. 141200         ADD 11 TO LINE-CTR.
  17051. 141300         PERFORM 590-WRT-ERROR-VR1.
  17052. 141400 535-EXIT-PRT-VR1.
  17053. 141500     EXIT.
  17054. 141600 550-PRT-HDNG-VR.
  17055. 141700     PERFORM 432-VALIDATE-ST-VR THRU 434-EXIT.
  17056. 141800 560-PRT-HDNG.
  17057. 141900     ADD 1 TO PAGE-CTR.
  17058. 142000     MOVE PAGE-CTR TO HDR-PG.
  17059. 142100     WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
  17060. 142200     WRITE PRT-REC FROM VR-HDR-ST AFTER ADVANCING 2 LINES.
  17061. 142300     MOVE 3 TO LINE-CTR.
  17062. 142400 580-EXAMINE-ID.
  17063. 142500     SUBTRACT 1 FROM I.
  17064. 142600 585-MV-HDR-DET-VR.
  17065. 142700     MOVE SPACES TO VR-HDR-DET-LN1.
  17066. 142800     MOVE GRP1-VR1Z TO HDR-VR-REC-TYP-P.
  17067. 142900     MOVE ADST-CD-VR1Z TO HDR-VR-ST-P.
  17068. 143000     MOVE DATA-DATE-VR1Z TO HDR-VR-DATE-P.
  17069. 143100     MOVE ACTION-CD-VR1Z TO HDR-VR-ACTN-P.
  17070. 143200     MOVE RNG-SITE-ID-VR1Z TO HDR-VR-RNG-SITE-NO-P.
  17071. 143300 590-WRT-ERROR-VR1.
  17072. 143400     MOVE SPACES TO VR1-HDR-DET-LN2.
  17073. 143500     IF  LINE-CTR > 50
  17074. 143600         PERFORM 560-PRT-HDNG.
  17075. 143700     MOVE LIN-NUM-VR1Z TO VR1-LIN-NUM-P.
  17076. 143800     MOVE RNG-SITE-NAM-VR1Z TO VR1-RNGSITE-NM-P.
  17077. 143900     MOVE PRECIP-ZONE-VR1Z TO VR1-PRECIP-P.
  17078. 144000     MOVE SSF-VAL-AVG-VR1Z TO VR1-SOIL-SURF-P.
  17079. 144100     MOVE POTN-PPA-RS-VR1Z (1) TO VR1-AVG-YR-P.
  17080. 144200     MOVE POTN-PPA-RS-VR1Z (2) TO VR1-FAVORABLE-YR-P.
  17081. 144300     MOVE POTN-PPA-RS-VR1Z (3) TO VR1-UNFAVORABLE-YR-P.
  17082. 144400     WRITE PRT-REC FROM VR1-HDR-DET-LN2 AFTER ADVANCING 2 LINES.
  17083. 144500     WRITE PRT-REC FROM VR1-HDR-ASTERISK-LN2 AFTER ADVANCING
  17084. 144600                  1 LINES.
  17085. 144700     MOVE SPACES TO VR-HDR-ASTERISK-LN1 VR1-HDR-ASTERISK-LN2.
  17086. 144800     ADD 3 TO LINE-CTR.
  17087. 144900 600-CHK-VR2D.
  17088. 145000     IF  HLD-RNG-SITE-ID = RNG-SITE-ID-VR2Z NEXT SENTENCE
  17089. 145100     ELSE
  17090. 145200         MOVE 0 TO RNGE-SITE-SAME
  17091. 145300         MOVE SPACES TO HDR-VR-RNG-SITE-NO-ERR
  17092. 145400         MOVE "VR2 EDIT ERROR LISTING" TO HDR-VR-TIT
  17093. 145500         MOVE 0 TO SWITCH-LINE1
  17094. 145600         MOVE ADST-CD-VR2Z TO HLD-ST
  17095. 145700         MOVE REC-TYP-HLD TO REC-TYP-HLD-2
  17096. 145800         MOVE RNG-SITE-ID-VR2Z TO HLD-RNG-SITE-ID
  17097. 145900         PERFORM 620A-CHK-RNGSITE THRU 621A-EXIT
  17098. 146000         PERFORM 550-PRT-HDNG-VR
  17099. 146100         GO TO 620-EDIT-VR2D.
  17100. 146200     MOVE 1 TO RNGE-SITE-SAME.
  17101. 146300     IF  HLD-ST = ADST-CD-VR2Z NEXT SENTENCE
  17102. 146400     ELSE
  17103. 146500         MOVE 1 TO PAGE-CTR
  17104. 146600         MOVE "VR2 EDIT ERROR LISTING" TO HDR-VR-TIT
  17105. 146700         MOVE 0 TO SWITCH-LINE1
  17106. 146800         MOVE ADST-CD-VR1Z TO HLD-ST
  17107. 146900         MOVE REC-TYP-HLD TO REC-TYP-HLD-2
  17108. 147000         PERFORM 550-PRT-HDNG-VR.
  17109. 147100 620-EDIT-VR2D.
  17110. 147200     IF  GRP1-VR2Z NOT = "VR2D"
  17111. 147300         MOVE ALL "*" TO HDR-VR-REC-TYP-ERR.
  17112. 147400     IF  ACTION-CD-VR2Z NOT = "A" AND "D"
  17113. 147500         MOVE "*" TO HDR-VR-ACTN-ERR.
  17114. 147600         GO TO 621A-CHK-PLNT-CD.
  17115. 147700 620A-CHK-RNGSITE.
  17116. 147800     IF RNG-SITE-ID-VR1Z = ZERO OR
  17117. 147900         RNG-SITE-ID-VR1Z = SPACE
  17118. 148000         MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
  17119. 148100     MOVE RNG-SITE-ID-VR1Z TO RANGE-SITE-ID.
  17120. 148200     EXAMINE MLRA TALLYING ALL SPACE.
  17121. 148300     IF TALLY > ZERO
  17122. 148400         MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
  17123. 148500     MOVE 8 TO I.
  17124. 148600     PERFORM 580-EXAMINE-ID UNTIL I < 1 OR RNG-CHAR (I)
  17125. 148700         NOT = SPACE.
  17126. 148800     EXAMINE RNG-NUM TALLYING UNTIL FIRST SPACE.
  17127. 148900     IF I > 0
  17128. 149000         IF TALLY NOT = I
  17129. 149100             MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
  17130. 149200     IF RNG-SITE-ID-4-VR1Z = "G58C" OR "G59C"
  17131. 149300         GO TO 621-CHK-RNG-SITE-VR2Z.
  17132. 149400     MOVE RNG-SITE-ID-4-VR1Z TO DE-CD-8822-DEC.
  17133. 149500     MOVE "3902" TO DE-NO-8801-DEC.
  17134. 149600     FIND ANY CODE-DEC.
  17135. 149700     MOVE DB-STATUS TO DB-STAT.
  17136. 149800     IF NOT OK
  17137. 149900         MOVE ALL "*" TO VR-RNGSITE-ERR-4.
  17138. 150000 621-CHK-RNG-SITE-VR2Z.
  17139. 150100     IF RNG-SITE-ID-3-VR1Z NOT NUMERIC
  17140. 150200         MOVE ALL "*" TO VR-RNGSITE-ERR-3.
  17141. 150300 621A-EXIT.
  17142. 150400    EXIT.
  17143. 150500 621A-CHK-PLNT-CD.
  17144. 150600     IF PLANT-CD-VR2Z (1) = SPACE
  17145. 150700         MOVE SPACE TO PLANT-TYP-VR2Z (1)
  17146. 150800         GO TO 622-CHK-PLNT-CD2.
  17147. 150900         MOVE "2646" TO DE-NO-8801-DEC
  17148. 151000         MOVE PLANT-CD-VR2Z (1) TO DE-CD-8822-DEC
  17149. 151100         FIND ANY CODE-DEC
  17150. 151200         MOVE DB-STATUS TO DB-STAT
  17151. 151300         IF NOT OK
  17152. 151400            IF PLANT-CD-VR2Z (1) = "BARREN"
  17153. 151500               MOVE SPACE TO PLANT-TYP-VR2Z (1)
  17154. 151600               GO TO 622-CHK-PLNT-CD2
  17155. 151700            ELSE
  17156. 151800             MOVE ALL "*" TO VR2-PLANT-CD1-ERR
  17157. 151900             GO TO 622-CHK-PLNT-CD2.
  17158. 152000         GET CODE-DEC.
  17159. 152100         MOVE DB-STATUS TO DB-STAT
  17160. 152200         IF NOT OK
  17161. 152300             MOVE ALL "*" TO VR2-PLANT-CD1-ERR
  17162. 152400             GO TO 622-CHK-PLNT-CD2.
  17163. 152500     MOVE DE-CD-NAM-8823-DEC TO DICTIONARY-SEPARATE
  17164. 152600     IF  PLANT-TYP NOT = "G" AND "F" AND "S" AND "T"
  17165. 152700         MOVE ALL "*" TO VR2-PLANT-CD1-ERR.
  17166. 152800     MOVE PLANT-TYP TO PLANT-TYP-VR2Z (1).
  17167. 152900 622-CHK-PLNT-CD2.
  17168. 153000     IF PLANT-CD-VR2Z (2) = SPACE
  17169. 153100         MOVE SPACE TO PLANT-TYP-VR2Z (2)
  17170. 153200         GO TO 624-CHK-PLNT-CD3.
  17171. 153300         MOVE "2646" TO DE-NO-8801-DEC
  17172. 153400         MOVE PLANT-CD-VR2Z (2) TO DE-CD-8822-DEC
  17173. 153500         FIND ANY CODE-DEC
  17174. 153600         MOVE DB-STATUS TO DB-STAT
  17175. 153700         IF NOT OK
  17176. 153800            IF PLANT-CD-VR2Z (2) = "BARREN"
  17177. 153900               MOVE SPACE TO PLANT-TYP-VR2Z (2)
  17178. 154000               GO TO 624-CHK-PLNT-CD3
  17179. 154100            ELSE
  17180. 154200             MOVE ALL "*" TO VR2-PLANT-CD2-ERR
  17181. 154300             GO TO 624-CHK-PLNT-CD3.
  17182. 154400            GET CODE-DEC
  17183. 154500            MOVE DB-STATUS TO DB-STAT
  17184. 154600            IF NOT OK
  17185. 154700                MOVE ALL "*" TO VR2-PLANT-CD2-ERR
  17186. 154800                GO TO 624-CHK-PLNT-CD3.
  17187. 154900                MOVE DE-CD-NAM-8823-DEC TO DICTIONARY-SEPARATE
  17188. 155000               IF PLANT-TYP NOT = "G" AND "F" AND "S"
  17189. 155100                 AND "T"
  17190. 155200                 MOVE ALL "*" TO VR2-PLANT-CD2-ERR.
  17191. 155300                MOVE PLANT-TYP TO PLANT-TYP-VR2Z (2).
  17192. 155400 624-CHK-PLNT-CD3.
  17193. 155500     IF PLANT-CD-VR2Z (3) = SPACE
  17194. 155600         MOVE SPACE TO PLANT-TYP-VR2Z (3)
  17195. 155700         GO TO 626-CHK-PLNT-CD4.
  17196. 155800         MOVE "2646" TO DE-NO-8801-DEC
  17197. 155900         MOVE PLANT-CD-VR2Z (3) TO DE-CD-8822-DEC
  17198. 156000         FIND ANY CODE-DEC
  17199. 156100         MOVE DB-STATUS TO DB-STAT
  17200. 156200         IF NOT OK
  17201. 156300            IF PLANT-CD-VR2Z (3) = "BARREN"
  17202. 156400               MOVE SPACE TO PLANT-TYP-VR2Z (3)
  17203. 156500               GO TO 626-CHK-PLNT-CD4
  17204. 156600             ELSE
  17205. 156700            MOVE ALL "*" TO VR2-PLANT-CD3-ERR
  17206. 156800            GO TO 626-CHK-PLNT-CD4.
  17207. 156900            GET CODE-DEC
  17208. 157000            MOVE DB-STATUS TO DB-STAT
  17209. 157100            IF NOT OK
  17210. 157200            MOVE ALL "*" TO VR2-PLANT-CD3-ERR
  17211. 157300            GO TO 626-CHK-PLNT-CD4.
  17212. 157400                MOVE DE-CD-NAM-8823-DEC TO DICTIONARY-SEPARATE
  17213. 157500                IF PLANT-TYP NOT = "G" AND "F" AND "S"
  17214. 157600                   AND "T"
  17215. 157700                   MOVE ALL "*" TO VR2-PLANT-CD3-ERR.
  17216. 157800                MOVE PLANT-TYP TO PLANT-TYP-VR2Z (3).
  17217. 157900 626-CHK-PLNT-CD4.
  17218. 158000     IF PLANT-CD-VR2Z (4) = SPACE
  17219. 158100         MOVE SPACE TO PLANT-TYP-VR2Z (4)
  17220. 158200         GO TO 628-CHK-PCT-COMP.
  17221. 158300         MOVE "2646" TO DE-NO-8801-DEC
  17222. 158400         MOVE PLANT-CD-VR2Z (4) TO DE-CD-8822-DEC
  17223. 158500         FIND ANY CODE-DEC
  17224. 158600         MOVE DB-STATUS TO DB-STAT
  17225. 158700         IF NOT OK
  17226. 158800            IF PLANT-CD-VR2Z (4) = "BARREN"
  17227. 158900               MOVE SPACE TO PLANT-TYP-VR2Z (4)
  17228. 159000               GO TO 628-CHK-PCT-COMP
  17229. 159100            ELSE
  17230. 159200         MOVE ALL "*" TO VR2-PLANT-CD4-ERR
  17231. 159300         GO TO 628-CHK-PCT-COMP.
  17232. 159400            GET CODE-DEC
  17233. 159500            MOVE DB-STATUS TO DB-STAT
  17234. 159600            IF NOT OK
  17235. 159700                 MOVE ALL "*" TO VR2-PLANT-CD4-ERR
  17236. 159800                 GO TO 628-CHK-PCT-COMP.
  17237. 159900                MOVE DE-CD-NAM-8823-DEC TO DICTIONARY-SEPARATE
  17238. 160000                IF PLANT-TYP NOT = "G" AND "F" AND "S"
  17239. 160100                   AND "T"
  17240. 160200                   MOVE ALL "*" TO VR2-PLANT-CD4-ERR.
  17241. 160300                MOVE PLANT-TYP TO PLANT-TYP-VR2Z (4).
  17242. 160400 628-CHK-PCT-COMP.
  17243. 160500     IF PLANT-CD-VR2Z (1) NOT = SPACE AND
  17244. 160600       ((PCT-COMP-VR2Z (1) = SPACE)
  17245. 160700         OR (PCT-COMP-VR2Z (1) NOT NUMERIC))
  17246. 160800       MOVE ALL "*" TO VR2-COMP-PCT1-ERR.
  17247. 160900     IF PLANT-CD-VR2Z (2) NOT = SPACE AND
  17248. 161000       ((PCT-COMP-VR2Z (2) = SPACE)
  17249. 161100         OR (PCT-COMP-VR2Z (2) NOT NUMERIC))
  17250. 161200       MOVE ALL "*" TO VR2-COMP-PCT2-ERR.
  17251. 161300     IF PLANT-CD-VR2Z (3) NOT = SPACE AND
  17252. 161400       ((PCT-COMP-VR2Z (3) = SPACE)
  17253. 161500         OR (PCT-COMP-VR2Z (3) NOT NUMERIC))
  17254. 161600       MOVE ALL "*" TO VR2-COMP-PCT3-ERR.
  17255. 161700     IF PLANT-CD-VR2Z (4) NOT = SPACE AND
  17256. 161800       ((PCT-COMP-VR2Z (4) = SPACE)
  17257. 161900         OR (PCT-COMP-VR2Z (4) NOT NUMERIC))
  17258. 162000       MOVE ALL "*" TO VR2-COMP-PCT4-ERR.
  17259. 162100     IF VR-HDR-ASTERISK-LN1 = SPACES AND
  17260. 162200        VR2-HDR-ASTERISK-LN2 = SPACES
  17261. 162300        WRITE VR-VB-OT-REC FROM VR2-REC-HLD
  17262. 162400        ADD 1 TO GOOD-CTR
  17263. 162500         GO TO 675-EXIT-PRT-VR2.
  17264. 162600     MOVE 1 TO ERR-FREE.
  17265. 162700     ADD 1 TO ERROR-CTR.
  17266. 162800     IF  SWITCH-LINE1 = 1
  17267. 162900         PERFORM 690-WRT-ERROR-VR2
  17268. 163000         GO TO 675-EXIT-PRT-VR2
  17269. 163100     ELSE
  17270. 163200         MOVE 1 TO SWITCH-LINE1
  17271. 163300         PERFORM 560-PRT-HDNG
  17272. 163400         PERFORM 275-WRT-HDR-ST
  17273. 163500         PERFORM 585-MV-HDR-DET-VR
  17274. 163600         WRITE PRT-REC FROM VR-HDR-REC1 AFTER ADVANCING 2 LINES.
  17275. 163700         WRITE PRT-REC FROM VR-HDR-REC2 AFTER ADVANCING 1 LINES.
  17276. 163800         WRITE PRT-REC FROM VR-HDR-REC3 AFTER ADVANCING 1 LINES.
  17277. 163900         WRITE PRT-REC FROM VR-HDR-DET-LN1 AFTER ADVANCING 2
  17278. 164000                                                 LINES.
  17279. 164100         WRITE PRT-REC FROM VR-HDR-ASTERISK-LN1 AFTER ADVANCING
  17280. 164200                                                1 LINES.
  17281. 164300         WRITE PRT-REC FROM VR2-HDR-REC1 AFTER ADVANCING 2 LINES.
  17282. 164400         WRITE PRT-REC FROM VR2-HDR-REC2 AFTER ADVANCING 1 LINES.
  17283. 164500         WRITE PRT-REC FROM VR2-HDR-REC3 AFTER ADVANCING 1 LINES.
  17284. 164600         ADD 11 TO LINE-CTR.
  17285. 164700         PERFORM 690-WRT-ERROR-VR2.
  17286. 164800 675-EXIT-PRT-VR2.
  17287. 164900     EXIT.
  17288. 165000 690-WRT-ERROR-VR2.
  17289. 165100     MOVE SPACES TO VR2-HDR-DET-LN2.
  17290. 165200     IF LINE-CTR > 50
  17291. 165300        PERFORM 560-PRT-HDNG.
  17292. 165400     MOVE LIN-NUM-VR2Z TO VR2-LIN-NUM-P.
  17293. 165500     MOVE PLANT-CD-VR2Z (1) TO VR2-PLANT-CD1-P.
  17294. 165600     MOVE PCT-COMP-VR2Z (1) TO VR2-COMP-PCT1-P.
  17295. 165700     MOVE PLANT-CD-VR2Z (2) TO VR2-PLANT-CD2-P.
  17296. 165800     MOVE PCT-COMP-VR2Z (2) TO VR2-COMP-PCT2-P.
  17297. 165900     MOVE PLANT-CD-VR2Z (3) TO VR2-PLANT-CD3-P.
  17298. 166000     MOVE PCT-COMP-VR2Z (3) TO VR2-COMP-PCT3-P.
  17299. 166100     MOVE PLANT-CD-VR2Z (4) TO VR2-PLANT-CD4-P.
  17300. 166200     MOVE PCT-COMP-VR2Z (4) TO VR2-COMP-PCT4-P.
  17301. 166300     WRITE PRT-REC FROM VR2-HDR-DET-LN2 AFTER ADVANCING 2 LINES.
  17302. 166400     WRITE PRT-REC FROM VR2-HDR-ASTERISK-LN2 AFTER ADVANCING
  17303. 166500               1 LINES.
  17304. 166600     MOVE SPACES TO VR2-HDR-ASTERISK-LN2.
  17305. 166700     ADD 3 TO LINE-CTR.
  17306. 166800 700-CHK-VR3D.
  17307. 166900     IF  HLD-RNG-SITE-ID = RNG-SITE-ID-VR3Z NEXT SENTENCE
  17308. 167000     ELSE
  17309. 167100         MOVE 0 TO RNGE-SITE-SAME
  17310. 167200         MOVE SPACES TO HDR-VR-RNG-SITE-NO-ERR
  17311. 167300         MOVE "VR3 EDIT ERROR LISTING" TO HDR-VR-TIT
  17312. 167400         MOVE 0 TO SWITCH-LINE1
  17313. 167500         MOVE ADST-CD-VR3Z TO HLD-ST
  17314. 167600         MOVE REC-TYP-HLD TO REC-TYP-HLD-2
  17315. 167700         MOVE RNG-SITE-ID-VR3Z TO HLD-RNG-SITE-ID
  17316. 167800         PERFORM 710-CHK-RNGSITE THRU 735-EXIT
  17317. 167900         PERFORM 550-PRT-HDNG-VR
  17318. 168000         GO TO 720-EDIT-VR3D.
  17319. 168100     MOVE 1 TO RNGE-SITE-SAME.
  17320. 168200     IF HLD-ST = ADST-CD-VR3Z NEXT SENTENCE
  17321. 168300     ELSE
  17322. 168400         MOVE 1 TO PAGE-CTR
  17323. 168500         MOVE "VR3 EDIT ERROR LISTING" TO HDR-VR-TIT
  17324. 168600         MOVE 0 TO SWITCH-LINE1
  17325. 168700         MOVE ADST-CD-VR1Z TO HLD-ST
  17326. 168800         MOVE REC-TYP-HLD TO REC-TYP-HLD-2
  17327. 168900         PERFORM 550-PRT-HDNG-VR.
  17328. 169000 720-EDIT-VR3D.
  17329. 169100     IF  REC-TYP-HLD-2 NOT = "VR3D"
  17330. 169200          MOVE ALL "*" TO HDR-VR-REC-TYP-ERR.
  17331. 169300     IF  ACTION-CD-VR3Z NOT = "A" AND "D"
  17332. 169400         MOVE "*" TO HDR-VR-ACTN-ERR.
  17333. 169500         GO TO 740-CHK-SOIL.
  17334. 169600 710-CHK-RNGSITE.
  17335. 169700     IF RNG-SITE-ID-VR1Z = ZERO OR
  17336. 169800         RNG-SITE-ID-VR1Z = SPACE
  17337. 169900         MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
  17338. 170000     MOVE RNG-SITE-ID-VR1Z TO RANGE-SITE-ID.
  17339. 170100     EXAMINE MLRA TALLYING ALL SPACE.
  17340. 170200     IF TALLY > ZERO
  17341. 170300         MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
  17342. 170400     MOVE 8 TO I.
  17343. 170500     PERFORM 580-EXAMINE-ID UNTIL I < 1 OR RNG-CHAR (I)
  17344. 170600         NOT = SPACE.
  17345. 170700     EXAMINE RNG-NUM TALLYING UNTIL FIRST SPACE.
  17346. 170800     IF I > 0
  17347. 170900         IF TALLY NOT = I
  17348. 171000             MOVE ALL "*" TO HDR-VR-RNG-SITE-NO-ERR.
  17349. 171100     IF RNG-SITE-ID-4-VR1Z = "G58C" OR "G59C"
  17350. 171200         GO TO 730-CHK-RNG-SITE-VR3Z.
  17351. 171300     MOVE RNG-SITE-ID-4-VR1Z TO DE-CD-8822-DEC.
  17352. 171400     MOVE "3902" TO DE-NO-8801-DEC.
  17353. 171500     FIND ANY CODE-DEC.
  17354. 171600     MOVE DB-STATUS TO DB-STAT.
  17355. 171700     IF NOT OK
  17356. 171800         MOVE ALL "*" TO VR-RNGSITE-ERR-4.
  17357. 171900 730-CHK-RNG-SITE-VR3Z.
  17358. 172000     IF RNG-SITE-ID-3-VR1Z NOT NUMERIC
  17359. 172100         MOVE ALL "*" TO VR-RNGSITE-ERR-3.
  17360. 172200 735-EXIT.
  17361. 172300     EXIT.
  17362. 172400 740-CHK-SOIL.
  17363. 172500*    IF SOIL-PHAS-VR3Z (1) NOT = SPACE
  17364. 172600*      AND SOIL-NAM-VR3Z (1) = SPACE
  17365. 172700*       MOVE ALL "*" TO VR3-SOIL-NM1-ERR.
  17366. 172800*    IF SOIL-PHAS-VR3Z (2) NOT = SPACE
  17367. 172900*      AND SOIL-NAM-VR3Z (2) = SPACE
  17368. 173000*      MOVE ALL "*" TO VR3-SOIL-NM2-ERR.
  17369. 173100    IF  VR-HDR-ASTERISK-LN1 = SPACES AND
  17370. 173200        VR3-HDR-ASTERISK-LN2 = SPACES
  17371. 173300        WRITE VR-VB-OT-REC FROM VR-VB-REC-HLD
  17372. 173400        ADD 1 TO GOOD-CTR
  17373. 173500        GO  TO 785-EXIT-PRT-VR3.
  17374. 173600    MOVE 1 TO ERR-FREE.
  17375. 173700    ADD 1 TO ERROR-CTR.
  17376. 173800    IF  SWITCH-LINE1 = 1
  17377. 173900         PERFORM 790-WRT-ERROR-VR3
  17378. 174000         GO TO 785-EXIT-PRT-VR3
  17379. 174100     ELSE
  17380. 174200         MOVE 1 TO SWITCH-LINE1
  17381. 174300         PERFORM 560-PRT-HDNG
  17382. 174400         PERFORM 275-WRT-HDR-ST
  17383. 174500        PERFORM 585-MV-HDR-DET-VR
  17384. 174600        WRITE PRT-REC FROM VR-HDR-REC1 AFTER ADVANCING 2 LINES.
  17385. 174700        WRITE PRT-REC FROM VR-HDR-REC2 AFTER ADVANCING 1 LINES.
  17386. 174800        WRITE PRT-REC FROM VR-HDR-REC3 AFTER ADVANCING 1 LINES.
  17387. 174900        WRITE PRT-REC FROM VR-HDR-DET-LN1 AFTER ADVANCING
  17388. 175000                                                 2 LINES.
  17389. 175100        WRITE PRT-REC FROM VR-HDR-ASTERISK-LN1 AFTER ADVANCING
  17390. 175200                                                 1 LINES.
  17391. 175300        WRITE PRT-REC FROM VR3-HDR-REC1 AFTER ADVANCING 2 LINES.
  17392. 175400        WRITE PRT-REC FROM VR3-HDR-REC2 AFTER ADVANCING 1 LINES.
  17393. 175500        WRITE PRT-REC FROM VR3-HDR-REC3 AFTER ADVANCING 1 LINES.
  17394. 175600        ADD 11 TO LINE-CTR.
  17395. 175700        PERFORM 790-WRT-ERROR-VR3.
  17396. 175800 785-EXIT-PRT-VR3.
  17397. 175900     EXIT.
  17398. 176000 790-WRT-ERROR-VR3.
  17399. 176100     MOVE SPACES TO VR3-HDR-DET-LN2.
  17400. 176200     IF  LINE-CTR > 50
  17401. 176300         PERFORM 560-PRT-HDNG.
  17402. 176400     MOVE LIN-NUM-VR3Z TO VR3-LIN-NUM-P.
  17403. 176500     MOVE SOIL-PHAS-VR3Z (1) TO VR3-SOIL-PHASE1-P.
  17404. 176600     MOVE SOIL-NAM-VR3Z (1) TO VR3-SOIL-NM1-P.
  17405. 176700     MOVE SOIL-PHAS-VR3Z (2) TO VR3-SOIL-PHASE2-P.
  17406. 176800     MOVE SOIL-NAM-VR3Z (2) TO VR3-SOIL-NM2-P.
  17407. 176900     WRITE PRT-REC FROM VR3-HDR-DET-LN2 AFTER ADVANCING 2 LINES.
  17408. 177000     WRITE PRT-REC FROM VR3-HDR-ASTERISK-LN2 AFTER ADVANCING
  17409. 177100                                           1 LINES.
  17410. 177200     ADD 3 TO LINE-CTR.
  17411. 000000*-----------------------------------------------------------------
  17412. 000100 IDENTIFICATION DIVISION.
  17413. 000200 PROGRAM-ID. ES410U.
  17414. 000300*        INITIAL EDIT/UPDATE OF LIVESTOCK (VL) AND
  17415. 000400*            WILDLIFE (VW) USE DATA.
  17416. 000500*
  17417. 000600 AUTHOR. CARLANDER.
  17418. 000700 INSTALLATION.         BLM.
  17419. 000800 DATE-WRITTEN.         AUGUST 1979.
  17420. 000900 ENVIRONMENT DIVISION.
  17421. 001000 CONFIGURATION SECTION.
  17422. 001100 SOURCE-COMPUTER.      LEVEL-66-ASCII.
  17423. 001200 OBJECT-COMPUTER.      LEVEL-66-ASCII SEQUENCE IS EBCDIC.
  17424. 001300 INPUT-OUTPUT SECTION.
  17425. 001400 FILE-CONTROL.
  17426. 001500     SELECT  NEW-FILE  ASSIGN D1
  17427. 001600             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  17428. 001700     SELECT  TRAN-FILE ASSIGN I1
  17429. 001800             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  17430. 001900     SELECT  OPTIONAL PREV-FILE ASSIGN I2
  17431. 002000             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  17432. 002100     SELECT  SORT-WORK ASSIGN I1 I2 I3.
  17433. 002200 DATA DIVISION.
  17434. 002300 FILE SECTION.
  17435. 002400*
  17436. 002500 FD  PREV-FILE
  17437. 002600     CODE-SET IS GBCD
  17438. 002700     LABEL RECORDS ARE STANDARD
  17439. 002800     DATA RECORDS ARE VL1X-RCD VW1X-RCD.
  17440. 002900 01  VL1X-RCD.
  17441. 003000     02  REC-TYP-3529-VL1X           PIC X(02).
  17442. 003100     02  FMT-NUM-3576-VL1X           PIC X(01).
  17443. 003200     02  FMT-CD-3579-VL1X            PIC X(01).
  17444. 003300     02  SDRP-VL1X.
  17445. 003400         03 BLM-ADM-U-ST-0003-VL1X   PIC X(02).
  17446. 003500         03 BLM-ADM-U-DIST-0003-VL1X PIC X(02).
  17447. 003600         03 BLM-ADM-U-RA-0003-VL1X   PIC X(02).
  17448. 003700         03 BLM-ADM-U-PLU-0003-VL1X  PIC X(02).
  17449. 003800     02  DATA-DATE-6618-VL1X    PIC X(06).
  17450. 003900     02  ACTN-CD-7350-VL1X      PIC X(01).
  17451. 004000     02  LIN-NUM-3578-VL1X     PIC X(04).
  17452. 004100     02  VL1X-DATA OCCURS 2 TIMES.
  17453. 004200         03  ALLOT-NUM-0968-VL1X    PIC X(04).
  17454. 004300         03  PASTURE-NUM-3905-VL1X  PIC X(02).
  17455. 004400         03  ANML-GRZG-CD-3929-VL1X PIC X(02).
  17456. 004500         03  ANML-EST-POP-3926-VL1X PIC X(05).
  17457. 004600         03  USE-DATES-3845-1ST-VL1X PIC X(04).
  17458. 004700         03  USE-DATES-3845-END-VL1X PIC X(04).
  17459. 004800     02  VL1X-OPEN              PIC X(13).
  17460. 004900 01  VW1X-RCD.
  17461. 005000     02  REC-TYP-3529-VW1X           PIC X(02).
  17462. 005100     02  FMT-NUM-3576-VW1X           PIC X(01).
  17463. 005200     02  FMT-CD-3579-VW1X            PIC X(01).
  17464. 005300     02  SDRP-VW1X.
  17465. 005400         03 BLM-ADM-U-ST-0003-VW1X   PIC X(02).
  17466. 005500         03 BLM-ADM-U-DIST-0003-VW1X PIC X(02).
  17467. 005600         03 BLM-ADM-U-RA-0003-VW1X   PIC X(02).
  17468. 005700         03 BLM-ADM-U-PLU-0003-VW1X  PIC X(02).
  17469. 005800     02  DATA-DATE-6618-VW1X    PIC X(06).
  17470. 005900     02  ACTN-CD-7350-VW1X      PIC X(01).
  17471. 006000     02  LIN-NUM-3578-VW1X     PIC X(04).
  17472. 006100     02  HERD-UNIT-NUM-6598-VW1X       PIC X(08).
  17473. 006200     02  ALLOT-NUM-0968-VW1X         PIC X(04).
  17474. 006300     02  HERD-UNIT-ALLOT-PCT-3927-VW1X   PIC X(03).
  17475. 006400     02  ANML-GRZG-CD-3929-VW1X          PIC X(02).
  17476. 006500     02  ANML-EST-POP-3926-VW1X     PIC X(05).
  17477. 006600     02  USE-DATES-3845-1ST-VW1X        PIC X(04).
  17478. 006700     02  USE-DATES-3845-END-VW1X   PIC X(04).
  17479. 006800     02  SWA-3507-VW1X                  PIC X(04) OCCURS 5 TIMES.
  17480. 006900     02  VW1X-OPEN                      PIC X(05).
  17481. 007000*
  17482. 007100 FD  TRAN-FILE
  17483. 007200     CODE-SET IS GBCD
  17484. 007300     LABEL RECORDS ARE STANDARD
  17485. 007400     DATA RECORDS ARE RCD-TF.
  17486. 007500 01  RCD-TF.
  17487. 007600     03  REC-TYP-TF     PIC X(02).
  17488. 007700     03  FILLER         PIC X(16).
  17489. 007800     03  ACTN-CD-TF        PIC X.
  17490. 007900     03  LINE-TF        PIC X(04).
  17491. 008000     03  ALLOT-VL-TF    PIC XXXX.
  17492. 008100     03  PAST-VL-TF     PIC XX.
  17493. 008200     03  ANML-CD-VL-TF  PIC XX.
  17494. 008300     03  ALLOT-VW-TF    PIC XXXX.
  17495. 008400     03  FILLER         PIC XXX.
  17496. 008500     03  ANML-CD-VW-TF  PIC XX.
  17497. 008600     03  FILLER        PIC X(38).
  17498. 008700*
  17499. 008800 FD  NEW-FILE
  17500. 008900     CODE-SET IS GBCD
  17501. 009000     LABEL RECORDS ARE STANDARD
  17502. 009100     DATA RECORDS ARE VL1Z-RCD VW1Z-RCD.
  17503. 009200 01  VL1Z-RCD.
  17504. 009300     02  REC-TYP-3529-VL1Z           PIC X(02).
  17505. 009400     02  FMT-NUM-3576-VL1Z           PIC X(01).
  17506. 009500     02  FMT-CD-3579-VL1Z            PIC X(01).
  17507. 009600     02  SDRP-VL1Z.
  17508. 009700         03 BLM-ADM-U-ST-0003-VL1Z   PIC X(02).
  17509. 009800         03 BLM-ADM-U-DIST-0003-VL1Z PIC X(02).
  17510. 009900         03 BLM-ADM-U-RA-0003-VL1Z   PIC X(02).
  17511. 010000         03 BLM-ADM-U-PLU-0003-VL1Z  PIC X(02).
  17512. 010100     02  DATA-DATE-6618-VL1Z    PIC X(06).
  17513. 010200     02  ACTN-CD-7350-VL1Z      PIC X(01).
  17514. 010300     02  LIN-NUM-3578-VL1Z     PIC X(04).
  17515. 010400     02  VL1Z-DATA OCCURS 2 TIMES.
  17516. 010500         03  ALLOT-NUM-0968-VL1Z    PIC X(04).
  17517. 010600         03  PASTURE-NUM-3905-VL1Z  PIC X(02).
  17518. 010700         03  ANML-GRZG-CD-3929-VL1Z PIC X(02).
  17519. 010800         03  ANML-EST-POP-3926-VL1Z PIC X(05).
  17520. 010900         03  USE-DATES-3845-1ST-VL1Z PIC X(04).
  17521. 011000         03  USE-DATES-3845-END-VL1Z PIC X(04).
  17522. 011100     02  VL1Z-OPEN              PIC X(13).
  17523. 011200 01  VW1Z-RCD.
  17524. 011300     02  REC-TYP-3529-VW1Z           PIC X(02).
  17525. 011400     02  FMT-NUM-3576-VW1Z           PIC X(01).
  17526. 011500     02  FMT-CD-3579-VW1Z            PIC X(01).
  17527. 011600     02  SDRP-VW1Z.
  17528. 011700         03 BLM-ADM-U-ST-0003-VW1Z   PIC X(02).
  17529. 011800         03 BLM-ADM-U-DIST-0003-VW1Z PIC X(02).
  17530. 011900         03 BLM-ADM-U-RA-0003-VW1Z   PIC X(02).
  17531. 012000         03 BLM-ADM-U-PLU-0003-VW1Z  PIC X(02).
  17532. 012100     02  DATA-DATE-6618-VW1Z    PIC X(06).
  17533. 012200     02  ACTN-CD-7350-VW1Z      PIC X(01).
  17534. 012300     02  LIN-NUM-3578-VW1Z     PIC X(04).
  17535. 012400     02  HERD-UNIT-NUM-6598-VW1Z       PIC X(08).
  17536. 012500     02  ALLOT-NUM-0968-VW1Z         PIC X(04).
  17537. 012600     02  HERD-UNIT-ALLOT-PCT-3927-VW1Z   PIC X(03).
  17538. 012700     02  ANML-GRZG-CD-3929-VW1Z          PIC X(02).
  17539. 012800     02  ANML-EST-POP-3926-VW1Z     PIC X(05).
  17540. 012900     02  USE-DATES-3845-1ST-VW1Z        PIC X(04).
  17541. 013000     02  USE-DATES-3845-END-VW1Z   PIC X(04).
  17542. 013100     02  SWA-3507-VW1Z                  PIC X(04) OCCURS 5 TIMES.
  17543. 013200     02  VW1Z-OPEN                      PIC X(05).
  17544. 013300*
  17545. 013400 SD  SORT-WORK
  17546. 013500     DATA RECORD IS SORT-RCD.
  17547. 013600 01  SORT-RCD.
  17548. 013700     03  SORT-REC.
  17549. 013800         05  SR-1-12.
  17550. 013900             07   SR-1-2  PIC X(02).
  17551. 014000             07   SR-3-12 PIC X(10).
  17552. 014100         05  SR-13-19     PIC X(07).
  17553. 014200         05  SR-LINE     PIC X(04).
  17554. 014300         05  SR-DATA      PIC X(55).
  17555. 014400     03  SR-KEYS.
  17556. 014500         05  SR-ALLOT     PIC XXXX.
  17557. 014600         05  SR-PAST      PIC XX.
  17558. 014700         05  SR-ANML-CD   PIC XX.
  17559. 014800     03  FILLER           PIC XXXX.
  17560. 014900*
  17561. 015000 WORKING-STORAGE SECTION.
  17562. 015100 77  END-OF-TRAN        PIC X(01) VALUE " ".
  17563. 015200 77  END-OF-PREV        PIC X(01) VALUE " ".
  17564. 015300 77  LAST-LIN-NUM       PIC 9(04) VALUE 0000.
  17565. 015400 77  DATE-SW            PIC X(01).
  17566. 015500 77  DATE-MV-SW         PIC X(01).
  17567. 015600 77  TODAYS-DATE        PIC X(06).
  17568. 015700 77  SORT-SV             PIC X(78) VALUE SPACES.
  17569. 015800*
  17570. 015900 01  PARAMETER.
  17571. 016000     03  RELINE-CHK    PIC XXX.
  17572. 016100     03  FILLER        PIC X(77).
  17573. 016200 01  CTRS.
  17574. 016300     02  VL-CTR     PIC 99999 VALUE 0.
  17575. 016400     02  VW-CTR     PIC 99999 VALUE 0.
  17576. 016500*
  17577. 016600 01  DATE-WORK.
  17578. 016700     02  DW-YY         PIC X(02).
  17579. 016800     02  DW-MM         PIC X(02).
  17580. 016900     02  DW-DD         PIC X(02).
  17581. 017000 01  MOVED-DATE.
  17582. 017100     02  MD-DD         PIC XX.
  17583. 017200     02  MD-YY         PIC XX.
  17584. 017300     02  MD-MM         PIC XX.
  17585. 017400*
  17586. 017500 01  TRAN-CTL.
  17587. 017600     02  TC-1-12    PIC X(12) VALUE SPACES.
  17588. 017700     02  TC-LINE    PIC X(04) VALUE SPACES.
  17589. 017800 01  PREV-CTL.
  17590. 017900     02  PC-1-12     PIC X(12) VALUE SPACES.
  17591. 018000     02  PC-13-16   PIC X(04) VALUE SPACES.
  17592. 018100*
  17593. 018200 01  CTL         PIC X(12).
  17594. 018300 01  CTL-SAVE                    PIC X(12) VALUE SPACES.
  17595. 018400*
  17596. 018500 01  VL1K-RCD.
  17597. 018600     02  REC-TYP-3529-VL1K           PIC X(02).
  17598. 018700     02  FMT-NUM-3576-VL1K           PIC X(01).
  17599. 018800     02  FMT-CD-3579-VL1K            PIC X(01).
  17600. 018900     02  SDRP-VL1K.
  17601. 019000         03 BLM-ADM-U-ST-0003-VL1K   PIC X(02).
  17602. 019100         03 BLM-ADM-U-DIST-0003-VL1K PIC X(02).
  17603. 019200         03 BLM-ADM-U-RA-0003-VL1K   PIC X(02).
  17604. 019300         03 BLM-ADM-U-PLU-0003-VL1K  PIC X(02).
  17605. 019400     02  DATA-DATE-6618-VL1K    PIC X(06).
  17606. 019500     02  ACTN-CD-7350-VL1K      PIC X(01).
  17607. 019600     02  LIN-NUM-3578-VL1K     PIC X(04).
  17608. 019700     02  VL1K-DATA OCCURS 2 TIMES.
  17609. 019800         03  ALLOT-NUM-0968-VL1K    PIC X(04).
  17610. 019900         03  PASTURE-NUM-3905-VL1K  PIC X(02).
  17611. 020000         03  ANML-GRZG-CD-3929-VL1K PIC X(02).
  17612. 020100         03  ANML-EST-POP-3926-VL1K PIC X(05).
  17613. 020200         03  USE-DATES-3845-1ST-VL1K PIC X(04).
  17614. 020300         03  USE-DATES-3845-END-VL1K PIC X(04).
  17615. 020400     02  VL1K-OPEN              PIC X(13).
  17616. 020500 01  VW1K-RCD.
  17617. 020600     02  REC-TYP-3529-VW1K           PIC X(02).
  17618. 020700     02  FMT-NUM-3576-VW1K           PIC X(01).
  17619. 020800     02  FMT-CD-3579-VW1K            PIC X(01).
  17620. 020900     02  SDRP-VW1K.
  17621. 021000         03 BLM-ADM-U-ST-0003-VW1K   PIC X(02).
  17622. 021100         03 BLM-ADM-U-DIST-0003-VW1K PIC X(02).
  17623. 021200         03 BLM-ADM-U-RA-0003-VW1K   PIC X(02).
  17624. 021300         03 BLM-ADM-U-PLU-0003-VW1K  PIC X(02).
  17625. 021400     02  DATA-DATE-6618-VW1K    PIC X(06).
  17626. 021500     02  ACTN-CD-7350-VW1K      PIC X(01).
  17627. 021600     02  LIN-NUM-3578-VW1K     PIC X(04).
  17628. 021700     02  HERD-UNIT-NUM-6598-VW1K       PIC X(08).
  17629. 021800     02  ALLOT-NUM-0968-VW1K         PIC X(04).
  17630. 021900     02  HERD-UNIT-ALLOT-PCT-3927-VW1K   PIC X(03).
  17631. 022000     02  ANML-GRZG-CD-3929-VW1K          PIC X(02).
  17632. 022100     02  ANML-EST-POP-3926-VW1K     PIC X(05).
  17633. 022200     02  USE-DATES-3845-1ST-VW1K        PIC X(04).
  17634. 022300     02  USE-DATES-3845-END-VW1K   PIC X(04).
  17635. 022400     02  SWA-3507-VW1K                  PIC X(04) OCCURS 5 TIMES.
  17636. 022500     02  VW1K-OPEN                      PIC X(05).
  17637. 022600*
  17638. 022700 PROCEDURE DIVISION.
  17639. 022800*
  17640. 022900 000-DRIVER SECTION.
  17641. 023000 010-MAINLINE.
  17642. 023100     PERFORM 100-INITIALIZE.
  17643. 023200     PERFORM 200-SORT.
  17644. 023300     PERFORM 990-TERMINATE.
  17645. 023400     STOP RUN.
  17646. 023500*
  17647. 023600 100-INITIALIZE SECTION.
  17648. 023700 110-OPENS.
  17649. 023800     OPEN INPUT PREV-FILE TRAN-FILE
  17650. 023900          OUTPUT NEW-FILE.
  17651. 024000     MOVE ALL "9" TO PREV-CTL.
  17652. 024100     ACCEPT TODAYS-DATE FROM DATE.
  17653. 024200     ACCEPT PARAMETER.
  17654. 024300*
  17655. 024400 200-SORT SECTION.
  17656. 024500 210-SORT-VERB.
  17657. 024600     SORT SORT-WORK
  17658. 024700            ASCENDING SR-1-12 SR-LINE SR-KEYS
  17659. 024800            INPUT PROCEDURE 300-READ-FORMAT
  17660. 024900            OUTPUT PROCEDURE 400-MATCH-UPDATE.
  17661. 025000*
  17662. 025100 300-READ-FORMAT SECTION.
  17663. 025200 310-READ.
  17664. 025300     READ TRAN-FILE
  17665. 025400         AT END GO TO 300-EXIT.
  17666. 025500     IF ACTN-CD-TF = SPACE
  17667. 025600         MOVE "A" TO ACTN-CD-TF.
  17668. 025700     MOVE RCD-TF TO SORT-RCD.
  17669. 025800     IF (SR-LINE NOT NUMERIC) OR (SR-LINE = "0000")
  17670. 025900         OR (RELINE-CHK = "YES")
  17671. 026000         MOVE "9999" TO SR-LINE.
  17672. 026100     MOVE SPACE TO SR-KEYS.
  17673. 026200     IF REC-TYP-TF = "VL"
  17674. 026300         MOVE ALLOT-VL-TF TO SR-ALLOT
  17675. 026400         MOVE PAST-VL-TF TO SR-PAST
  17676. 026500         MOVE ANML-CD-VL-TF TO SR-ANML-CD.
  17677. 026600     IF REC-TYP-TF = "VW"
  17678. 026700         MOVE ALLOT-VW-TF TO SR-ALLOT
  17679. 026800         MOVE ANML-CD-VW-TF TO SR-ANML-CD.
  17680. 026900     RELEASE SORT-RCD.
  17681. 027000     GO TO 310-READ.
  17682. 027100 300-EXIT.
  17683. 027200     EXIT.
  17684. 027300*
  17685. 027400 400-MATCH-UPDATE SECTION.
  17686. 027500 410-GET-FIRST-RCDS.
  17687. 027600     PERFORM 430-RETURN-SORT.
  17688. 027700     PERFORM 440-READ-PREV.
  17689. 027800 420-COMPARE.
  17690. 027900     IF TRAN-CTL IS EQUAL TO ALL "9" AND
  17691. 028000        PREV-CTL IS EQUAL TO ALL "9"
  17692. 028100             GO TO 400-EXIT.
  17693. 028200     IF TRAN-CTL IS GREATER THAN PREV-CTL
  17694. 028300             PERFORM 500-NO-TRAN
  17695. 028400             GO TO 420-COMPARE.
  17696. 028500     IF PREV-CTL IS GREATER THAN TRAN-CTL
  17697. 028600             PERFORM 600-NO-PREV
  17698. 028700             GO TO 420-COMPARE.
  17699. 028800     IF TRAN-CTL IS EQUAL TO PREV-CTL
  17700. 028900             PERFORM 700-MATCH.
  17701. 029000     GO TO 420-COMPARE.
  17702. 029100 430-RETURN-SORT.
  17703. 029200     RETURN SORT-WORK AT END
  17704. 029300             MOVE "X" TO END-OF-TRAN.
  17705. 029400     IF SORT-REC = SORT-SV AND
  17706. 029500        END-OF-TRAN NOT = "X"
  17707. 029600             GO TO 430-RETURN-SORT.
  17708. 029700     MOVE SORT-REC TO SORT-SV.
  17709. 029800     IF SR-1-2 IS EQUAL TO "VL"
  17710. 029900             MOVE SORT-REC TO VL1K-RCD
  17711. 030000             ELSE
  17712. 030100             MOVE SORT-REC TO VW1K-RCD.
  17713. 030200     MOVE SORT-REC TO TRAN-CTL.
  17714. 030300     MOVE SR-LINE TO TC-LINE.
  17715. 030400     IF END-OF-TRAN IS EQUAL TO "X"
  17716. 030500             MOVE ALL "9" TO TRAN-CTL.
  17717. 030600 440-READ-PREV.
  17718. 030700     READ PREV-FILE AT END
  17719. 030800             MOVE "X" TO END-OF-PREV.
  17720. 030900     MOVE VL1X-RCD TO PREV-CTL.
  17721. 031000     MOVE LIN-NUM-3578-VL1X TO PC-13-16.
  17722. 031100     IF END-OF-PREV = "X"
  17723. 031200             MOVE ALL "9" TO PREV-CTL.
  17724. 031300*
  17725. 031400 500-NO-TRAN.
  17726. 031500     MOVE VL1X-RCD     TO VL1Z-RCD.
  17727. 031600     PERFORM 800-ADD-TO-CTRS.
  17728. 031700     PERFORM 920-WRITE-Z-RCD.
  17729. 031800     PERFORM 440-READ-PREV.
  17730. 031900*
  17731. 032000 600-NO-PREV.
  17732. 032100     MOVE SORT-REC  TO VL1Z-RCD.
  17733. 032200     PERFORM 800-ADD-TO-CTRS.
  17734. 032300     PERFORM 830-CHECK-LIN-NUM THRU 830-OUT.
  17735. 032400     PERFORM 890-EDIT-DATE.
  17736. 032500     PERFORM 920-WRITE-Z-RCD.
  17737. 032600     PERFORM 430-RETURN-SORT.
  17738. 032700*
  17739. 032800 700-MATCH.
  17740. 032900     MOVE VL1X-RCD     TO VL1Z-RCD.
  17741. 033000     PERFORM 890-EDIT-DATE.
  17742. 033100     IF SR-DATA NOT = SPACES AND
  17743. 033200        REC-TYP-3529-VL1Z = "VL"
  17744. 033300             PERFORM 850-MOVE-VL-FIELDS
  17745. 033400             PERFORM 800-ADD-TO-CTRS
  17746. 033500             PERFORM 920-WRITE-Z-RCD.
  17747. 033600     IF SR-DATA NOT = SPACES AND
  17748. 033700        REC-TYP-3529-VL1Z = "VW"
  17749. 033800             PERFORM 860-MOVE-VW-FIELDS
  17750. 033900             PERFORM 800-ADD-TO-CTRS
  17751. 034000             PERFORM 920-WRITE-Z-RCD.
  17752. 034100     PERFORM 430-RETURN-SORT.
  17753. 034200     PERFORM 440-READ-PREV.
  17754. 034300*
  17755. 034400 800-ADD-TO-CTRS.
  17756. 034500     IF REC-TYP-3529-VL1Z = "VL"
  17757. 034600             ADD 1 TO VL-CTR
  17758. 034700           ELSE
  17759. 034800             ADD 1 TO VW-CTR.
  17760. 034900*
  17761. 035000 830-CHECK-LIN-NUM.
  17762. 035100     IF LIN-NUM-3578-VL1Z NOT = ALL "9"
  17763. 035200             GO TO 830-OUT.
  17764. 035300     MOVE VL1Z-RCD       TO CTL.
  17765. 035400     IF CTL NOT = CTL-SAVE
  17766. 035500             MOVE 0001 TO LAST-LIN-NUM
  17767. 035600            MOVE "0001" TO LIN-NUM-3578-VL1Z
  17768. 035700       ELSE
  17769. 035800             ADD 1     TO LAST-LIN-NUM
  17770. 035900             MOVE LAST-LIN-NUM TO LIN-NUM-3578-VL1Z.
  17771. 036000     MOVE  CTL           TO CTL-SAVE.
  17772. 036100 830-OUT.
  17773. 036200     EXIT.
  17774. 036300*
  17775. 036400 850-MOVE-VL-FIELDS.
  17776. 036500     IF ALLOT-NUM-0968-VL1K (1) = SPACES
  17777. 036600             NEXT SENTENCE
  17778. 036700       ELSE
  17779. 036800           IF ALLOT-NUM-0968-VL1K (1) = "****"
  17780. 036900                  MOVE SPACES TO ALLOT-NUM-0968-VL1Z (1)
  17781. 037000                ELSE
  17782. 037100     MOVE ALLOT-NUM-0968-VL1K (1) TO ALLOT-NUM-0968-VL1Z (1).
  17783. 037200     IF PASTURE-NUM-3905-VL1K (1) = SPACES
  17784. 037300             NEXT SENTENCE
  17785. 037400       ELSE
  17786. 037500           IF PASTURE-NUM-3905-VL1K (1) = "**"
  17787. 037600                  MOVE SPACES TO PASTURE-NUM-3905-VL1Z (1)
  17788. 037700                ELSE
  17789. 037800     MOVE PASTURE-NUM-3905-VL1K (1) TO PASTURE-NUM-3905-VL1Z (1).
  17790. 037900     IF ANML-GRZG-CD-3929-VL1K (1) = SPACES
  17791. 038000             NEXT SENTENCE
  17792. 038100       ELSE
  17793. 038200           IF ANML-GRZG-CD-3929-VL1K (1) = "**"
  17794. 038300                  MOVE SPACES TO ANML-GRZG-CD-3929-VL1Z (1)
  17795. 038400                ELSE
  17796. 038500     MOVE ANML-GRZG-CD-3929-VL1K (1) TO
  17797. 038600          ANML-GRZG-CD-3929-VL1Z (1).
  17798. 038700     IF ANML-EST-POP-3926-VL1K (1) = SPACES
  17799. 038800             NEXT SENTENCE
  17800. 038900       ELSE
  17801. 039000*          IF ANML-EST-POP-3926-VL1K (1) = "*****"
  17802. 039100           IF ANML-EST-POP-3926-VL1K (1) = "00000"
  17803. 039200                  MOVE SPACES TO ANML-EST-POP-3926-VL1Z (1)
  17804. 039300                ELSE
  17805. 039400     MOVE ANML-EST-POP-3926-VL1K (1) TO
  17806. 039500          ANML-EST-POP-3926-VL1Z (1).
  17807. 039600     IF USE-DATES-3845-END-VL1K (1) = SPACES
  17808. 039700             NEXT SENTENCE
  17809. 039800       ELSE
  17810. 039900           IF USE-DATES-3845-END-VL1K (1) = "****"
  17811. 040000                  MOVE SPACES TO USE-DATES-3845-END-VL1Z (1)
  17812. 040100                ELSE
  17813. 040200     MOVE USE-DATES-3845-END-VL1K (1) TO
  17814. 040300          USE-DATES-3845-END-VL1Z (1).
  17815. 040400     IF USE-DATES-3845-1ST-VL1K (1) = SPACES
  17816. 040500             NEXT SENTENCE
  17817. 040600       ELSE
  17818. 040700           IF USE-DATES-3845-1ST-VL1K (1) = "****"
  17819. 040800                  MOVE SPACES TO USE-DATES-3845-1ST-VL1Z (1)
  17820. 040900                ELSE
  17821. 041000     MOVE USE-DATES-3845-1ST-VL1K (1) TO
  17822. 041100          USE-DATES-3845-1ST-VL1Z (1).
  17823. 041200     IF ALLOT-NUM-0968-VL1K (2) = SPACES
  17824. 041300             NEXT SENTENCE
  17825. 041400       ELSE
  17826. 041500           IF ALLOT-NUM-0968-VL1K (2) = "****"
  17827. 041600                  MOVE SPACES TO ALLOT-NUM-0968-VL1Z (2)
  17828. 041700                ELSE
  17829. 041800     MOVE ALLOT-NUM-0968-VL1K (2) TO ALLOT-NUM-0968-VL1Z (2).
  17830. 041900     IF PASTURE-NUM-3905-VL1K (2) = SPACES
  17831. 042000             NEXT SENTENCE
  17832. 042100       ELSE
  17833. 042200           IF PASTURE-NUM-3905-VL1K (2) = "**"
  17834. 042300                  MOVE SPACES TO PASTURE-NUM-3905-VL1Z (2)
  17835. 042400                ELSE
  17836. 042500     MOVE PASTURE-NUM-3905-VL1K (2) TO PASTURE-NUM-3905-VL1Z (2).
  17837. 042600     IF ANML-GRZG-CD-3929-VL1K (2) = SPACES
  17838. 042700             NEXT SENTENCE
  17839. 042800       ELSE
  17840. 042900           IF ANML-GRZG-CD-3929-VL1K (2) = "**"
  17841. 043000                  MOVE SPACES TO ANML-GRZG-CD-3929-VL1Z (2)
  17842. 043100                ELSE
  17843. 043200     MOVE ANML-GRZG-CD-3929-VL1K (2) TO
  17844. 043300          ANML-GRZG-CD-3929-VL1Z (2).
  17845. 043400     IF ANML-EST-POP-3926-VL1K (2) = SPACES
  17846. 043500             NEXT SENTENCE
  17847. 043600       ELSE
  17848. 043700*          IF ANML-EST-POP-3926-VL1K (2) = "*****"
  17849. 043800           IF ANML-EST-POP-3926-VL1K (2) = "00000"
  17850. 043900                  MOVE SPACES TO ANML-EST-POP-3926-VL1Z (2)
  17851. 044000                ELSE
  17852. 044100     MOVE ANML-EST-POP-3926-VL1K (2) TO
  17853. 044200          ANML-EST-POP-3926-VL1Z (2).
  17854. 044300     IF USE-DATES-3845-END-VL1K (2) = SPACES
  17855. 044400             NEXT SENTENCE
  17856. 044500       ELSE
  17857. 044600           IF USE-DATES-3845-END-VL1K (2) = "****"
  17858. 044700                  MOVE SPACES TO USE-DATES-3845-END-VL1Z (2)
  17859. 044800                ELSE
  17860. 044900     MOVE USE-DATES-3845-END-VL1K (2) TO
  17861. 045000          USE-DATES-3845-END-VL1Z (2).
  17862. 045100     IF USE-DATES-3845-1ST-VL1K (2) = SPACES
  17863. 045200             NEXT SENTENCE
  17864. 045300       ELSE
  17865. 045400           IF USE-DATES-3845-1ST-VL1K (2) = "****"
  17866. 045500                  MOVE SPACES TO USE-DATES-3845-1ST-VL1Z (2)
  17867. 045600                ELSE
  17868. 045700     MOVE USE-DATES-3845-1ST-VL1K (2) TO
  17869. 045800          USE-DATES-3845-1ST-VL1Z (2).
  17870. 045900*
  17871. 046000 860-MOVE-VW-FIELDS.
  17872. 046100     IF HERD-UNIT-NUM-6598-VW1K = SPACES
  17873. 046200             NEXT SENTENCE
  17874. 046300             ELSE
  17875. 046400             IF HERD-UNIT-NUM-6598-VW1K = "********"
  17876. 046500                  MOVE SPACES TO HERD-UNIT-NUM-6598-VW1Z
  17877. 046600                  ELSE
  17878. 046700                 MOVE HERD-UNIT-NUM-6598-VW1K TO
  17879. 046800                      HERD-UNIT-NUM-6598-VW1Z.
  17880. 046900     IF ALLOT-NUM-0968-VW1K = SPACES
  17881. 047000             NEXT SENTENCE
  17882. 047100             ELSE
  17883. 047200             IF ALLOT-NUM-0968-VW1K = "****"
  17884. 047300                  MOVE SPACES TO ALLOT-NUM-0968-VW1Z
  17885. 047400                  ELSE
  17886. 047500                 MOVE ALLOT-NUM-0968-VW1K TO
  17887. 047600                      ALLOT-NUM-0968-VW1Z.
  17888. 047700     IF HERD-UNIT-ALLOT-PCT-3927-VW1K = SPACES
  17889. 047800             NEXT SENTENCE
  17890. 047900             ELSE
  17891. 048000             IF HERD-UNIT-ALLOT-PCT-3927-VW1K = "***"
  17892. 048100                  MOVE SPACES TO HERD-UNIT-ALLOT-PCT-3927-VW1Z
  17893. 048200                  ELSE
  17894. 048300                 MOVE HERD-UNIT-ALLOT-PCT-3927-VW1K TO
  17895. 048400                      HERD-UNIT-ALLOT-PCT-3927-VW1Z.
  17896. 048500     IF ANML-GRZG-CD-3929-VW1K = SPACES
  17897. 048600             NEXT SENTENCE
  17898. 048700             ELSE
  17899. 048800             IF ANML-GRZG-CD-3929-VW1K = "**"
  17900. 048900                  MOVE SPACES TO ANML-GRZG-CD-3929-VW1Z
  17901. 049000                  ELSE
  17902. 049100                 MOVE ANML-GRZG-CD-3929-VW1K TO
  17903. 049200                     ANML-GRZG-CD-3929-VW1Z.
  17904. 049300     IF ANML-EST-POP-3926-VW1K = SPACES
  17905. 049400             NEXT SENTENCE
  17906. 049500             ELSE
  17907. 049600             IF ANML-EST-POP-3926-VW1K = "*****"
  17908. 049700                  MOVE SPACES TO ANML-EST-POP-3926-VW1Z
  17909. 049800                  ELSE
  17910. 049900                 MOVE ANML-EST-POP-3926-VW1K TO
  17911. 050000                     ANML-EST-POP-3926-VW1Z.
  17912. 050100     IF USE-DATES-3845-1ST-VW1K = SPACES
  17913. 050200             NEXT SENTENCE
  17914. 050300             ELSE
  17915. 050400             IF USE-DATES-3845-1ST-VW1K = "****"
  17916. 050500                  MOVE SPACES TO USE-DATES-3845-1ST-VW1Z
  17917. 050600                  ELSE
  17918. 050700                 MOVE USE-DATES-3845-1ST-VW1K TO
  17919. 050800                     USE-DATES-3845-1ST-VW1Z.
  17920. 050900     IF USE-DATES-3845-END-VW1K = SPACES
  17921. 051000             NEXT SENTENCE
  17922. 051100             ELSE
  17923. 051200             IF USE-DATES-3845-END-VW1K = "****"
  17924. 051300                  MOVE SPACES TO USE-DATES-3845-END-VW1Z
  17925. 051400                  ELSE
  17926. 051500                 MOVE USE-DATES-3845-END-VW1K TO
  17927. 051600                     USE-DATES-3845-END-VW1Z.
  17928. 051700     IF SWA-3507-VW1K (1)  = SPACES
  17929. 051800             NEXT SENTENCE
  17930. 051900             ELSE
  17931. 052000             IF SWA-3507-VW1K (1)  = "****"
  17932. 052100                  MOVE SPACES TO SWA-3507-VW1Z (1)
  17933. 052200                  ELSE
  17934. 052300                 MOVE SWA-3507-VW1K (1)  TO
  17935. 052400                     SWA-3507-VW1Z (1).
  17936. 052500     IF SWA-3507-VW1K (2)  = SPACES
  17937. 052600             NEXT SENTENCE
  17938. 052700             ELSE
  17939. 052800             IF SWA-3507-VW1K (2)  = "****"
  17940. 052900                  MOVE SPACES TO SWA-3507-VW1Z (2)
  17941. 053000                  ELSE
  17942. 053100                 MOVE SWA-3507-VW1K (2)  TO
  17943. 053200                     SWA-3507-VW1Z (2).
  17944. 053300     IF SWA-3507-VW1K (3)  = SPACES
  17945. 053400             NEXT SENTENCE
  17946. 053500             ELSE
  17947. 053600             IF SWA-3507-VW1K (3)  = "****"
  17948. 053700                  MOVE SPACES TO SWA-3507-VW1Z (3)
  17949. 053800                  ELSE
  17950. 053900                 MOVE SWA-3507-VW1K (3)  TO
  17951. 054000                     SWA-3507-VW1Z (3).
  17952. 054100     IF SWA-3507-VW1K (4)  = SPACES
  17953. 054200             NEXT SENTENCE
  17954. 054300             ELSE
  17955. 054400             IF SWA-3507-VW1K (4)  = "****"
  17956. 054500                  MOVE SPACES TO SWA-3507-VW1Z (4)
  17957. 054600                  ELSE
  17958. 054700                 MOVE SWA-3507-VW1K (4)  TO
  17959. 054800                     SWA-3507-VW1Z (4).
  17960. 054900     IF SWA-3507-VW1K (5)  = SPACES
  17961. 055000             NEXT SENTENCE
  17962. 055100             ELSE
  17963. 055200             IF SWA-3507-VW1K (5)  = "****"
  17964. 055300                  MOVE SPACES TO SWA-3507-VW1Z (5)
  17965. 055400                  ELSE
  17966. 055500                 MOVE SWA-3507-VW1K (5)  TO
  17967. 055600                     SWA-3507-VW1Z (5).
  17968. 055700*
  17969. 055800 890-EDIT-DATE.
  17970. 055900     MOVE SPACE TO DATE-MV-SW.
  17971. 056000     IF REC-TYP-3529-VL1Z = "VL"
  17972. 056100             MOVE DATA-DATE-6618-VL1Z TO DATE-WORK
  17973. 056200           ELSE
  17974. 056300             MOVE DATA-DATE-6618-VW1Z TO DATE-WORK.
  17975. 056400     PERFORM 900-EDIT-FIELDS.
  17976. 056500     IF DATE-SW NOT = " "
  17977. 056600             PERFORM 910-SWITCH-FIELDS
  17978. 056700             PERFORM 900-EDIT-FIELDS.
  17979. 056800     IF DATE-SW NOT = " " AND
  17980. 056900        REC-TYP-3529-VL1Z = "VL"
  17981. 057000             MOVE TODAYS-DATE TO DATA-DATE-6618-VL1Z.
  17982. 057100     IF DATE-SW NOT = " " AND
  17983. 057200        REC-TYP-3529-VL1Z = "VW"
  17984. 057300             MOVE TODAYS-DATE TO DATA-DATE-6618-VW1Z.
  17985. 057400     IF DATE-MV-SW NOT = " " AND
  17986. 057500        REC-TYP-3529-VL1Z = "VL"
  17987. 057600             MOVE MOVED-DATE  TO DATA-DATE-6618-VL1Z.
  17988. 057700     IF DATE-MV-SW NOT = " " AND
  17989. 057800        REC-TYP-3529-VL1Z = "VW"
  17990. 057900             MOVE MOVED-DATE  TO DATA-DATE-6618-VW1Z.
  17991. 058000 900-EDIT-FIELDS.
  17992. 058100     MOVE SPACE TO DATE-SW.
  17993. 058200     IF DW-MM NOT NUMERIC OR
  17994. 058300        DW-MM > "12"      OR
  17995. 058400        DW-MM < "01"
  17996. 058500             MOVE "X" TO DATE-SW.
  17997. 058600     IF DW-DD NOT NUMERIC OR
  17998. 058700        DW-DD < "01"      OR
  17999. 058800        DW-DD > "31"
  18000. 058900             MOVE "X" TO DATE-SW.
  18001. 059000     IF DW-YY NOT NUMERIC OR
  18002. 059100        DW-YY < "78"
  18003. 059200             MOVE "X" TO DATE-SW.
  18004. 059300 910-SWITCH-FIELDS.
  18005. 059400     IF DW-DD = "78" OR "79" OR "80" OR "81" OR "82"
  18006. 059500             MOVE DW-MM TO MD-MM
  18007. 059600             MOVE DW-DD TO MD-DD
  18008. 059700             MOVE DW-YY TO MD-YY
  18009. 059800             MOVE MOVED-DATE TO DATE-WORK
  18010. 059900             MOVE "X"   TO DATE-MV-SW.
  18011. 060000*
  18012. 060100 920-WRITE-Z-RCD.
  18013. 060200     MOVE VL1Z-RCD TO CTL CTL-SAVE.
  18014. 060300     MOVE LIN-NUM-3578-VW1Z TO LAST-LIN-NUM.
  18015. 060400     IF REC-TYP-3529-VL1Z = "VL"
  18016. 060500             MOVE SPACES TO VL1Z-OPEN   ELSE
  18017. 060600             MOVE SPACES TO VW1Z-OPEN.
  18018. 060700     MOVE "A" TO ACTN-CD-7350-VL1Z.
  18019. 060800     WRITE VL1Z-RCD.
  18020. 060900 400-EXIT.
  18021. 061000     EXIT.
  18022. 061100*
  18023. 061200 990-TERMINATE SECTION.
  18024. 061300 990-PRINT.
  18025. 061400     DISPLAY "   VL    VW".
  18026. 061500     DISPLAY VL-CTR " " VW-CTR.
  18027. 061600 990-CLOSE.
  18028. 061700     CLOSE PREV-FILE TRAN-FILE NEW-FILE.
  18029. 061800*
  18030. 000000*-----------------------------------------------------------------
  18031. 000100 IDENTIFICATION DIVISION.
  18032. 000200 PROGRAM-ID. ES415P.
  18033. 000300*        VL / VW VERIFICATION LIST
  18034. 000400*
  18035. 000500 AUTHOR. CORA FISCHER.
  18036. 000600 INSTALLATION.
  18037. 000700 DATE-WRITTEN.  7/29/80.
  18038. 000800 DATE-COMPILED.
  18039. 000900 ENVIRONMENT DIVISION.
  18040. 001000 CONFIGURATION SECTION.
  18041. 001100 SOURCE-COMPUTER. LEVEL-66-ASCII.
  18042. 001200 OBJECT-COMPUTER. LEVEL-66-ASCII.
  18043. 001300 INPUT-OUTPUT SECTION.
  18044. 001400 FILE-CONTROL.
  18045. 001500     SELECT  INPUT-FILE1 ASSIGN TO I1-ES410UD1
  18046. 001600         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  18047. 001700     SELECT  PRINT-FILE ASSIGN TO P1-PRINTER
  18048. 001800         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  18049. 001900     SELECT  SORT-FILE ASSIGN TO S1.
  18050. 002000 DATA DIVISION.
  18051. 002100 SUB-SCHEMA SECTION.
  18052. 002200 DB  CODVAL2 WITHIN BLMDIC.
  18053. 002300 FILE SECTION.
  18054. 002400 FD  INPUT-FILE1       CODE-SET IS GBCD
  18055. 002500                       LABEL RECORDS ARE STANDARD
  18056. 002600                       DATA RECORDS ARE FDR-VL  FDR-VW.
  18057. 002700 01  FDR-VL.
  18058. 002800     03  REC-TYPE-3529-VL-I1               PIC       X(02).
  18059. 002900     03  FMT-NO-3576-VL-I1                 PIC       X(01).
  18060. 003000     03  FMT-CD-3579-VL-I1                 PIC       X(01).
  18061. 003100     03  ADM-UNIT-0003-VL-I1               PIC       X(08).
  18062. 003200     03  DATA-DT-6618-VL-I1                PIC       X(06).
  18063. 003300     03  ACT-CD-7350-VL-I1                 PIC       X(01).
  18064. 003400     03  LINE-NO-3578-VL-I1                PIC       X(04).
  18065. 003500     03  LVSTK-USE-DATA-I1  OCCURS 2 TIMES.
  18066. 003600         05  ALLOT-NUM-0968-VL-I1          PIC       X(04).
  18067. 003700         05  PASTURE-NUM-3905-VL-I1        PIC       X(02).
  18068. 003800         05  ANML-GRZG-CD-3929-VL-I1       PIC       X(02).
  18069. 003900         05  ANML-EST-POP-3926-VL-I1       PIC       X(05).
  18070. 004000         05  USE-DATES-3845-VL-I1.
  18071. 004100           07  USE-MO-DT-FR-3845-VL-I1     PIC       X(02).
  18072. 004200           07  USE-DD-DT-FR-3845-VL-I1     PIC       X(02).
  18073. 004300           07  USE-MO-DT-TO-3845-VL-I1     PIC       X(02).
  18074. 004400           07  USE-DD-DT-TO-3845-VL-I1     PIC       X(02).
  18075. 004500     03  FILLER                            PIC       X(13).
  18076. 004600 01  FDR-VW.
  18077. 004700     03  REC-TYPE-3529-VW-I1               PIC       X(02).
  18078. 004800     03  FMT-NO-3576-VW-I1                 PIC       X(01).
  18079. 004900     03  FMT-CD-3579-VW-I1                 PIC       X(01).
  18080. 005000     03  ADM-UNIT-0003-VW-I1               PIC       X(08).
  18081. 005100     03  DATA-DT-6618-VW-I1                PIC       X(06).
  18082. 005200     03  ACT-CD-7350-VW-I1                 PIC       X(01).
  18083. 005300     03  LINE-NO-3578-VW-I1                PIC       X(04).
  18084. 005400     03  HERD-UNIT-NUM-6598-VW-I1          PIC       X(08).
  18085. 005500     03  ALLOT-NUM-0968-VW-I1              PIC       X(04).
  18086. 005600     03  HERD-UNIT-ALLOT-PCT-3927-VW-I1    PIC       X(03).
  18087. 005700     03  ANML-GRZG-CD-3929-VW-I1           PIC       X(02).
  18088. 005800     03  ANML-EST-POP-3926-VW-I1           PIC       X(05).
  18089. 005900     03  USE-DATES-3845-VW-I1.
  18090. 006000         05  USE-MO-DT-FR-3845-VW-I1       PIC       X(02).
  18091. 006100         05  USE-DD-DT-FR-3845-VW-I1       PIC       X(02).
  18092. 006200         05  USE-MO-DT-TO-3845-VW-I1       PIC       X(02).
  18093. 006300         05  USE-DD-DT-FR-3845-VW-I1       PIC       X(02).
  18094. 006400     03  SWA-3507-VW-I1          PIC  X(04) OCCURS 5 TIMES.
  18095. 006500     03  FILLER                            PIC       X(05).
  18096. 006600 FD  PRINT-FILE         CODE-SET IS GBCD
  18097. 006700                        LABEL RECORDS ARE STANDARD
  18098. 006800                        DATA RECORDS IS PRT-REC.
  18099. 006900 01  PRT-REC                      PIC     X(132).
  18100. 007000 SD  SORT-FILE         DATA RECORDS ARE S-KEY1  S-KEY2.
  18101. 007100 01  S-KEY1.
  18102. 007200     03  S-KEY-DATA-VL-S1.
  18103. 007300         05  REC-TYPE-3529-VL-S1           PIC       X(02).
  18104. 007400         05  FMT-NO-3576-VL-S1             PIC       X(01).
  18105. 007500         05  FMT-CD-3579-VL-S1             PIC       X(01).
  18106. 007600         05  ADM-UNIT-0003-VL-S1.
  18107. 007700           07  ADM-ST-0003-VL-S1           PIC       X(02).
  18108. 007800           07  ADM-DI-0003-VL-S1           PIC       X(02).
  18109. 007900           07  ADM-RA-0003-VL-S1           PIC       X(02).
  18110. 008000           07  ADM-PU-0003-VL-S1           PIC       X(02).
  18111. 008100         05  ALLOT-NUM1-0968-VL-S1         PIC       X(04).
  18112. 008200         05  PASTURE-NUM1-3905-VL-S1       PIC       X(02).
  18113. 008300         05  ANML-GRZG-CD1-3929-VL-S1      PIC       X(02).
  18114. 008400     03  DATA-DT-6618-VL-S1                PIC       X(06).
  18115. 008500     03  ACT-CD-7350-VL-S1                 PIC       X(01).
  18116. 008600     03  LINE-NO-3578-VL-S1                PIC       X(04).
  18117. 008700     03  ANML-EST-POP1-3926-VL-S1           PIC       X(05).
  18118. 008800     03  ANML-EST-POP2-3926-VL-S1           PIC       X(05).
  18119. 008900     03  USE-DATES-3845-VL-S1   OCCURS 2 TIMES.
  18120. 009000         05  USE-MO-DT-FR-3845-VL-S1       PIC       X(02).
  18121. 009100         05  USE-DD-DT-FR-3845-VL-S1       PIC       X(02).
  18122. 009200         05  USE-MO-DT-TO-3845-VL-S1       PIC       X(02).
  18123. 009300         05  USE-DD-DT-TO-3845-VL-S1       PIC       X(02).
  18124. 009400     03  ALLOT-NUM2-0968-VL-S1             PIC       X(04).
  18125. 009500     03  PASTURE-NUM2-3905-VL-S1           PIC       X(02).
  18126. 009600     03  ANML-GRZG-CD2-3929-VL-S1          PIC       X(02).
  18127. 009700     03  FILLER                            PIC       X(13).
  18128. 009800 01  S-KEY2.
  18129. 009900     03  S-KEY-DATA-VW-S1.
  18130. 010000         05  REC-TYPE-3529-VW-S1           PIC       X(02).
  18131. 010100         05  FMT-NO-3576-VW-S1             PIC       X(01).
  18132. 010200         05  FMT-CD-3579-VW-S1             PIC       X(01).
  18133. 010300         05  ADM-UNIT-0003-VW-S1.
  18134. 010400             07  ADM-ST-0003-VW-S1         PIC       X(02).
  18135. 010500             07  ADM-DI-0003-VW-S1         PIC       X(02).
  18136. 010600             07  ADM-RA-0003-VW-S1         PIC       X(02).
  18137. 010700             07  ADM-PU-0003-VW-S1         PIC       X(02).
  18138. 010800         05  ALLOT-NUM-0968-VW-S1          PIC       X(04).
  18139. 010900         05  FILLER                    PIC       X(02).
  18140. 011000         05  ANML-GRZG-CD-3929-VW-S1       PIC       X(02).
  18141. 011100     03  DATA-DT-6618-VW-S1                PIC       X(06).
  18142. 011200     03  ACT-CD-7350-VW-S1                 PIC       X(01).
  18143. 011300     03  LINE-NO-3578-VW-S1                PIC       X(04).
  18144. 011400     03  HERD-UNIT-NUM-6598-VW-S1          PIC       X(08).
  18145. 011500     03  HERD-UNIT-ALLOT-PCT-3927-VW-S1    PIC       X(03).
  18146. 011600     03  ANML-EST-POP-3926-VW-S1           PIC       X(05).
  18147. 011700     03  USE-DATES-3845-VW-S1.
  18148. 011800          05  USE-MO-DT-FR-3845-VW-S1      PIC       X(02).
  18149. 011900          05  USE-DD-DT-FR-3845-VW-S1      PIC       X(02).
  18150. 012000          05  USE-MO-DT-TO-3845-VW-S1      PIC       X(02).
  18151. 012100          05  USE-DD-DT-TO-3845-VW-S1      PIC       X(02).
  18152. 012200     03  SWA-3507-VW-S1          PIC X(04)  OCCURS 5 TIMES.
  18153. 012300     03  FILLER                  PIC  X(03).
  18154. 012400 WORKING-STORAGE SECTION.
  18155. 012500 77  PAGE-CNT                    PIC       9(05)     VALUE 0.
  18156. 012600 77  LINE-CNT                    PIC       9(02)     VALUE 66.
  18157. 012700 77  VL-CNT                      PIC       9(05)     VALUE 0.
  18158. 012800 77  VW-CNT                      PIC       9(05)     VALUE 0.
  18159. 012900 01  HLD-REC-TYPE                PIC       X(02)     VALUE SPACES.
  18160. 013000 01  MONTH-TABLE.
  18161. 013100     03  MO-TAB.
  18162. 013200         05  FILLER              PIC       X(03)     VALUE "JAN".
  18163. 013300         05  FILLER              PIC       X(03)     VALUE "FEB".
  18164. 013400         05  FILLER              PIC       X(03)     VALUE "MAR".
  18165. 013500         05  FILLER              PIC       X(03)     VALUE "APR".
  18166. 013600         05  FILLER              PIC       X(03)     VALUE "MAY".
  18167. 013700         05  FILLER              PIC       X(03)     VALUE "JUN".
  18168. 013800         05  FILLER              PIC       X(03)     VALUE "JUL".
  18169. 013900         05  FILLER              PIC       X(03)     VALUE "AUG".
  18170. 014000         05  FILLER              PIC       X(03)     VALUE "SEP".
  18171. 014100         05  FILLER              PIC       X(03)     VALUE "OCT".
  18172. 014200         05  FILLER              PIC       X(03)     VALUE "NOV".
  18173. 014300         05  FILLER              PIC       X(03)     VALUE "DEC".
  18174. 014400     03  MON REDEFINES MO-TAB    PIC       X(03) OCCURS 12 TIMES.
  18175. 014500 01  EOF-SWITCH                  PIC       9   VALUE 0.
  18176. 014600     88  EOF                               VALUE 1.
  18177. 014700 01  EOR-SWITCH                  PIC       9   VALUE 0.
  18178. 014800     88  EOR                     VALUE 1.
  18179. 014900 01  PARAMETER                   PIC       X(04).
  18180. 015000 01  HLD-DT.
  18181. 015100     03  HOLD-DT.
  18182. 015200         05  YR-DT               PIC       XX.
  18183. 015300         05  MO-DT               PIC       99.
  18184. 015400         05  DY-DT               PIC       XX.
  18185. 015500     03  INV-HLD.
  18186. 015600         05  INV-NM    PIC       X(20).
  18187. 015700         05  ST-DIST-CD.
  18188. 015800             07  ST-CD-HLD       PIC       X(02).
  18189. 015900             07  DI-CD-HLD       PIC       X(02).
  18190. 016000     03  EXPL-HLD.
  18191. 016100         05  DIST-NM-HLD         PIC       X(12).
  18192. 016200     03  FUNC-HLD.
  18193. 016300         05  ST-NM-HLD           PIC       X(10).
  18194. 016400         05  FILLER              PIC       X(14).
  18195. 016500     COPY DBSTATUS IN TPCOBOLIB.
  18196. 016600 01  HDR-1.
  18197. 016700     03  FILLER                  PIC       X(08)     VALUE
  18198. 016800         " DATE:  ".
  18199. 016900     03  HDR-MO                  PIC       X(03).
  18200. 017000     03  FILLER                  PIC       X(01)     VALUE SPACE.
  18201. 017100     03  HDR-DA                  PIC       X(02).
  18202. 017200     03  FILLER                  PIC       X(04)     VALUE ", 19".
  18203. 017300     03  HDR-YR                  PIC       X(02).
  18204. 017400     03  FILLER                  PIC       X(21)     VALUE SPACES.
  18205. 017500     03  FILLER                  PIC       X(47)     VALUE
  18206. 017600         "US DEPT OF INTERIOR - BUREAU OF LAND MANAGEMENT".
  18207. 017700     03  FILLER                  PIC       X(29)     VALUE SPACES.
  18208. 017800     03  FILLER                  PIC       X(07)     VALUE
  18209. 017900         "PAGE:  ".
  18210. 018000     03  HDR-PG                  PIC       ZZ,ZZ9.
  18211. 018100     03  FILLER                  PIC       X(02)     VALUE SPACES.
  18212. 018200 01  HDR-2.
  18213. 018300     03  FILLER                  PIC       X(8)      VALUE
  18214. 018400         "STATE:  ".
  18215. 018500     03  HDR-ST-CD               PIC       X(02).
  18216. 018600     03  FILLER                  PIC       X(04)     VALUE SPACES.
  18217. 018700     03  HDR-ST-NM               PIC       X(10).
  18218. 018800     03  FILLER                  PIC       X(30)     VALUE SPACES.
  18219. 018900     03  FILLER                  PIC       X(25)     VALUE
  18220. 019000         "ECOLOGICAL SITE INVENTORY".
  18221. 019100     03  FILLER                  PIC       X(35)     VALUE SPACES.
  18222. 019200     03  FILLER                  PIC       X(18)     VALUE
  18223. 019300         "PROGRAM:  ES415P  ".
  18224. 019400 01  HDR-3.
  18225. 019500     03  FILLER                  PIC       X(08)     VALUE
  18226. 019600         "   DI:  ".
  18227. 019700     03  HDR-DIST-CD             PIC       X(02).
  18228. 019800     03  FILLER                  PIC       X(04)     VALUE SPACES.
  18229. 019900     03  HDR-DIST-NM             PIC       X(25).
  18230. 020000     03  FILER                   PIC       X(79)     VALUE SPACES.
  18231. 020100     03  FILLER                  PIC       X(14)     VALUE
  18232. 020200         "PCN:  PCN415  ".
  18233. 020300 01  HDR-4.
  18234. 020400     03  FILLER                  PIC       X(08)     VALUE
  18235. 020500         "  INV:  ".
  18236. 020600     03  HDR-INV-CD              PIC       X(04).
  18237. 020700     03  FILLER                  PIC       X(02)     VALUE SPACES.
  18238. 020800     03  HDR-INV-NM              PIC       X(25).
  18239. 020900     03  FILLER                  PIC       X(16)     VALUE SPACES.
  18240. 021000     03  HDR-REC-TYPE            PIC       X(02).
  18241. 021100     03  FILLER                  PIC       X(18)     VALUE
  18242. 021200         " VERIFICATION LIST".
  18243. 021300     03  FILLER                  PIC       X(57)     VALUE SPACES.
  18244. 021400 01  HDR-5-VL.
  18245. 021500     03  FILLER                  PIC       X(38)     VALUE
  18246. 021600         "(1-2)        (3)             (4)   (5)".
  18247. 021700     03  FILLER                  PIC       X(10)     VALUE SPACES.
  18248. 021800     03  FILLER                  PIC       X(34)     VALUE
  18249. 021900         "(6)   (7)   (8)   (9)         (10)".
  18250. 022000     03  FILLER                  PIC       X(10)     VALUE SPACES.
  18251. 022100     03  FILLER                  PIC       X(40)     VALUE
  18252. 022200         "(6)   (7)  (8)   (9)         (10)       ".
  18253. 022300 01  HDR-6-VL.
  18254. 022400     03  FILLER                  PIC       X(43)     VALUE
  18255. 022500         " REC  ADMINISTRATIVE UNIT   DATE  ACT  LINE".
  18256. 022600     03  FILLER                  PIC       X(16)     VALUE SPACES.
  18257. 022700     03  FILLER                  PIC       X(27)     VALUE
  18258. 022800         "ANML  AUTH    PERIOD OF USE".
  18259. 022900     03  FILLER                  PIC       X(16)     VALUE SPACES.
  18260. 023000     03  FILLER                  PIC       X(30)     VALUE
  18261. 023100         "ANML  AUTH    PERIOD OF USE   ".
  18262. 023200 01  HDR-7-VL.
  18263. 023300     03  FILLER                  PIC       X(46)     VALUE
  18264. 023400         "TYPE  ST   DI   RA   PU   YYMMDD   CD   NUM   ".
  18265. 023500     03  FILLER                  PIC       X(51)     VALUE
  18266. 023600         "ALLOT  PAST  SPEC LVSTK FROM MM DD-TO MM DD ALLOT  ".
  18267. 023700     03  FILLER                  PIC       X(35)     VALUE
  18268. 023800         "PAST SPEC LVSTK FROM MM DD-TO MM DD".
  18269. 023900 01  HDR-8-VL.
  18270. 024000     03  FILLER                  PIC       X(52)     VALUE
  18271. 024100         " 1-4  5-6  7-8 9-10 11-12  13-18   19  20-23  24-27 ".
  18272. 024200     03  FILLER                  PIC       X(49)     VALUE
  18273. 024300         "28-29 30-31 32-36      37-40    41-44 45-48 49-50".
  18274. 024400     03  FILLER                  PIC       X(31)     VALUE
  18275. 024500         " 51-2 53-57      58-61    62-65".
  18276. 024600 01  HDR-9-VL.
  18277. 024700     03  FILLER                  PIC       X(53)     VALUE
  18278. 024800         "XXXX  XX   XX   XX   XX   XXXXXX   X   9999    9999  ".
  18279. 024900     03  FILLER                  PIC       X(54)     VALUE
  18280. 025000         " 99    XX  99999      XX XX    XX XX  9999   99   XX  ".
  18281. 025100     03  FILLER                  PIC       X(25)     VALUE
  18282. 025200         "99999      XX XX    XX XX".
  18283. 025300 01  HDR-10-DET-VL.
  18284. 025400     03  REC-TYPE-3529-VL-P1     PIC       X(02).
  18285. 025500     03  FMT-NO-3576-VL-P1       PIC       X(01).
  18286. 025600     03  FMT-CD-3579-VL-P1       PIC       X(01).
  18287. 025700     03  FILLER                  PIC       X(02)     VALUE SPACES.
  18288. 025800     03  ADM-ST-0003-VL-P1       PIC       X(02).
  18289. 025900     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18290. 026000     03  ADM-DI-0003-VL-P1       PIC       X(02).
  18291. 026100     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18292. 026200     03  ADM-RA-0003-VL-P1       PIC       X(02).
  18293. 026300     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18294. 026400     03  ADM-PU-0003-VL-P1       PIC       X(02).
  18295. 026500     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18296. 026600     03  DATA-DT-6618-VL-P1      PIC       X(06).
  18297. 026700     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18298. 026800     03  ACT-CD-7350-VL-P1       PIC       X(01).
  18299. 026900     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18300. 027000     03  LINE-NO-3578-VL-P1      PIC       X(04).
  18301. 027100     03  FILLER                  PIC       X(04)     VALUE SPACES.
  18302. 027200     03  ALLOT-NUM1-0968-VL-P1   PIC       X(04).
  18303. 027300     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18304. 027400     03  PASTURE-NUM1-3905-VL-P1 PIC       X(02).
  18305. 027500     03  FILLER                  PIC       X(04)     VALUE SPACES.
  18306. 027600     03  ANML-GRZG-CD1-3929-VL-P1 PIC      X(02).
  18307. 027700     03  FILLER                  PIC       X(02)     VALUE SPACES.
  18308. 027800     03  ANML-EST-POP1-3926-VL-P1 PIC      X(05).
  18309. 027900     03  FILLER                  PIC       X(06)     VALUE SPACES.
  18310. 028000     03  USE-MO-DT-FR1-3845-VL-P1          PIC       X(02).
  18311. 028100     03  FILLER                  PIC       X(01)     VALUE SPACE.
  18312. 028200     03  USE-DD-DT-FR1-3845-VL-P1          PIC       X(02).
  18313. 028300     03  FILLER                  PIC       X(04)     VALUE SPACES.
  18314. 028400     03  USE-MO-DT-TO1-3845-VL-P1 PIC      X(02).
  18315. 028500     03  FILLER                  PIC       X(01)     VALUE SPACE.
  18316. 028600     03  USE-DD-DT-TO1-3845-VL-P1 PIC      X(02).
  18317. 028700     03  FILLER                  PIC       X(02)     VALUE SPACES.
  18318. 028800     03  ALLOT-NUM2-0968-VL-P1   PIC       X(04).
  18319. 028900     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18320. 029000     03  PASTURE-NUM2-3905-VL-P1 PIC       X(02).
  18321. 029100     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18322. 029200     03  ANML-GRZG-CD2-3929-VL-P1 PIC      X(02).
  18323. 029300     03  FILLER                  PIC       X(02)     VALUE SPACES.
  18324. 029400     03  ANML-EST-POP2-3926-VL-P1 PIC      X(05).
  18325. 029500     03  FILLER                  PIC       X(06)     VALUE SPACES.
  18326. 029600     03  USE-MO-DT-FR2-3845-VL-P1          PIC       X(02).
  18327. 029700     03  FILLER                  PIC       X(01)      VALUE SPACE.
  18328. 029800     03  USE-DD-DT-FR2-3845-VL-P1          PIC       X(02).
  18329. 029900     03  FILLER                  PIC       X(04)     VALUE SPACES.
  18330. 030000     03  USE-MO-DT-TO2-3845-VL-P1          PIC       X(02).
  18331. 030100     03  FILLER                   PIC      X(01)     VALUE SPACE.
  18332. 030200     03  USE-DD-DT-TO2-3845-VL-P1 PIC      X(02).
  18333. 030300 01  HDR-5-VW.
  18334. 030400     03  FILLER                  PIC       X(53)     VALUE
  18335. 030500         "(1-2)        (3)             (4)   (5)            (6)".
  18336. 030600     03  FILLER                  PIC       X(29)     VALUE
  18337. 030700         "      (7)   (8)   (9)    (10)".
  18338. 030800     03  FILLER                  PIC       X(10)     VALUE SPACES.
  18339. 030900     03  FILLER                  PIC       X(4)      VALUE
  18340. 031000         "(11)".
  18341. 031100     03  FILLER                  PIC       X(21)     VALUE SPACES.
  18342. 031200     03  FILLER                  PIC       X(4)      VALUE "(12)".
  18343. 031300     03  FILLER                  PIC       X(11)     VALUE SPACES.
  18344. 031400 01  HDR-6-VW.
  18345. 031500     03  FILLER                  PIC       X(49)     VALUE
  18346. 031600         " REC  ADMINISTRATIVE UNIT   DATE   ACT  LINE     ".
  18347. 031700     03  FILLER                  PIC       X(51)     VALUE
  18348. 031800         "HERD            PCT  ANML EST NUM     PERIOD OF USE".
  18349. 031900     03  FILLER                  PIC       X(32)     VALUE
  18350. 032000         "     LSTG OF SWAS BY WLDLF SPEC ".
  18351. 032100 01  HDR-7-VW.
  18352. 032200     03  FILLER                  PIC       X(42)     VALUE
  18353. 032300         "TYPE  ST   DI   RA   PU    YYMMDD   CD  NO".
  18354. 032400     03  FILLER                  PIC       X(49)     VALUE
  18355. 032500         "      UNIT    ALLOT  HERD  SPEC   ANMLS  FROM MM ".
  18356. 032600     03  FILLER                  PIC       X(40)     VALUE
  18357. 032700         "DD-TO MM DD  SWA   SWA   SWA   SWA   SWA".
  18358. 032800 01  HDR-8-VW.
  18359. 032900     03  FILLER                  PIC       X(54)     VALUE
  18360. 033000         " 1-4  5-6  7-8 9-10 11-12  13-18    19  20-23    24-31".
  18361. 033100     03  FILLER                  PIC       X(49)     VALUE
  18362. 033200         "   32-35  36-8  39-40  41-45       46-49    50-53".
  18363. 033300     03  FILLER                  PIC       X(29)     VALUE
  18364. 033400         " 54-7  58-61 62-5  66-9  70-3".
  18365. 033500 01  HDR-9-VW.
  18366. 033600     03  FILLER                  PIC       X(47)     VALUE
  18367. 033700         "XXXX  XX   XX   XX   XX    XXXXXX   X   XXXX   ".
  18368. 033800     03  FILLER                  PIC       X(42)     VALUE
  18369. 033900         "XXXXXXXX   9999   999    XX   99999       ".
  18370. 034000     03  FILLER                  PIC       X(43)     VALUE
  18371. 034100         "XX XX    XX XX XXXX  XXXX  XXXX  XXXX  XXXX".
  18372. 034200 01  HDR-10-DET-VW.
  18373. 034300     03  REC-TYPE-3529-VW-P1     PIC       X(02).
  18374. 034400     03  FMT-NO-3576-VW-P1       PIC       X(01).
  18375. 034500     03  FMT-CD-3579-VW-P1       PIC       X(01).
  18376. 034600     03  FILLER                  PIC       X(02)     VALUE SPACES.
  18377. 034700     03  ADM-ST-0003-VW-P1       PIC       X(02).
  18378. 034800     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18379. 034900     03  ADM-DI-0003-VW-P1       PIC       X(02).
  18380. 035000     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18381. 035100     03  ADM-RA-0003-VW-P1       PIC       X(02).
  18382. 035200     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18383. 035300     03  ADM-PU-0003-VW-P1       PIC       X(02).
  18384. 035400     03  FILLER                  PIC       X(04)     VALUE SPACES.
  18385. 035500     03  DATA-DT-6618-VW-P1      PIC       X(06).
  18386. 035600     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18387. 035700     03  ACT-CD-7350-VW-P1       PIC       X(01).
  18388. 035800     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18389. 035900     03  LINE-NO-3578-VW-P1      PIC       X(04).
  18390. 036000     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18391. 036100     03  HERD-UNIT-NUM-6598-VW-P1 PIC       X(08).
  18392. 036200     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18393. 036300     03  ALLOT-NUM-0968-VW-P1    PIC       X(04).
  18394. 036400     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18395. 036500     03  HERD-UNIT-ALLOT-PCT-3927-VW-P1    PIC       X(03).
  18396. 036600     03  FILLER                  PIC       X(04)     VALUE SPACES.
  18397. 036700     03  ANML-GRZG-CD-3929-VW-P1 PIC       X(02).
  18398. 036800     03  FILLER                  PIC       X(03)     VALUE SPACES.
  18399. 036900     03  ANML-EST-POP-3926-VW-P1 PIC       X(05).
  18400. 037000     03  FILLER                  PIC       X(07)     VALUE SPACES.
  18401. 037100     03  USE-MO-DT-FR-3845-VW-P1 PIC       X(02).
  18402. 037200     03  FILLER                  PIC       X(01)     VALUE SPACES.
  18403. 037300     03  USE-DD-DT-FR-3845-VW-P1 PIC       X(02).
  18404. 037400     03  FILLER                  PIC       X(04)     VALUE SPACES.
  18405. 037500     03  USE-MO-DT-TO-3845-VW-P1 PIC       X(02).
  18406. 037600     03  FILLER                  PIC       X(01)     VALUE SPACE.
  18407. 037700     03  USE-DD-DT-TO-3845-VW-P1 PIC       X(02).
  18408. 037800     03  FILLER                  PIC       X(01)   VALUE SPACE.
  18409. 037900     03  SWA1-3507-VW-P1         PIC       X(04).
  18410. 038000     03  FILLER                  PIC       X(02)   VALUE SPACES.
  18411. 038100     03  SWA2-3507-VW-P1         PIC       X(04).
  18412. 038200     03  FILLER                  PIC       X(02)   VALUE SPACES.
  18413. 038300     03  SWA3-3507-VW-P1         PIC       X(04).
  18414. 038400     03  FILLER                  PIC       X(02)   VALUE SPACES.
  18415. 038500     03  SWA4-3507-VW-P1         PIC       X(04).
  18416. 038600     03  FILLER                  PIC       X(02)   VALUE SPACES.
  18417. 038700     03  SWA5-3507-VW-P1         PIC       X(04).
  18418. 038800 PROCEDURE DIVISION.
  18419. 038900 START-SORT SECTION.
  18420. 039000 100-SORT.
  18421. 039100         SORT SORT-FILE ON ASCENDING S-KEY-DATA-VL-S1
  18422. 039200             INPUT PROCEDURE PRE-SORT
  18423. 039300             OUTPUT PROCEDURE POST-SORT.
  18424. 039400 200-END-SECTION.
  18425. 039500     FINISH DIC-DE.
  18426. 039600     CLOSE PRINT-FILE.
  18427. 039700     DISPLAY "VL-CNT "  VL-CNT.
  18428. 039800     DISPLAY "VW-CNT "  VW-CNT.
  18429. 039900     STOP RUN.
  18430. 040000 PRE-SORT SECTION.
  18431. 040100 300-HSKPNG.
  18432. 040200     OPEN INPUT INPUT-FILE1.
  18433. 040300     MOVE SPACES TO S-KEY1  S-KEY2.
  18434. 040400 400-MAIN.
  18435. 040500     PERFORM  500-RD-FILE1 THRU 600-EXIT-RD-FL1 UNTIL EOF.
  18436. 040600     CLOSE INPUT-FILE1.
  18437. 040700     GO TO 850-EXIT-VW.
  18438. 040800 500-RD-FILE1.
  18439. 040900     READ INPUT-FILE1  AT END MOVE 1 TO EOF-SWITCH.
  18440. 041000     IF  (EOF-SWITCH = 1) GO TO 600-EXIT-RD-FL1.
  18441. 041100     IF  REC-TYPE-3529-VL-I1 = "VL"
  18442. 041200         PERFORM 700-MV-VL-TO-SRT THRU 750-EXIT-VL
  18443. 041300         GO  TO 600-EXIT-RD-FL1.
  18444. 041400     IF  REC-TYPE-3529-VW-I1 = "VW"
  18445. 041500         PERFORM 800-MV-VW-TO-SRT THRU 850-EXIT-VW
  18446. 041600         GO  TO 600-EXIT-RD-FL1.
  18447. 041700 600-EXIT-RD-FL1.
  18448. 041800     EXIT.
  18449. 041900 700-MV-VL-TO-SRT.
  18450. 042000     ADD 1 TO VL-CNT.
  18451. 042100     MOVE REC-TYPE-3529-VL-I1  TO REC-TYPE-3529-VL-S1.
  18452. 042200     MOVE FMT-NO-3576-VL-I1  TO FMT-NO-3576-VL-S1.
  18453. 042300     MOVE FMT-CD-3579-VL-I1 TO FMT-CD-3579-VL-S1.
  18454. 042400     MOVE ADM-UNIT-0003-VL-I1 TO ADM-UNIT-0003-VL-S1.
  18455. 042500     MOVE DATA-DT-6618-VL-I1 TO DATA-DT-6618-VL-S1.
  18456. 042600     MOVE ACT-CD-7350-VL-I1 TO ACT-CD-7350-VL-S1.
  18457. 042700     MOVE LINE-NO-3578-VL-I1 TO LINE-NO-3578-VL-S1.
  18458. 042800     MOVE ALLOT-NUM-0968-VL-I1 (1) TO ALLOT-NUM1-0968-VL-S1.
  18459. 042900     MOVE ALLOT-NUM-0968-VL-I1 (2) TO ALLOT-NUM2-0968-VL-S1.
  18460. 043000     MOVE PASTURE-NUM-3905-VL-I1 (1) TO PASTURE-NUM1-3905-VL-S1.
  18461. 043100     MOVE PASTURE-NUM-3905-VL-I1 (2) TO PASTURE-NUM2-3905-VL-S1.
  18462. 043200     MOVE ANML-GRZG-CD-3929-VL-I1 (1) TO ANML-GRZG-CD1-3929-VL-S1.
  18463. 043300     MOVE ANML-GRZG-CD-3929-VL-I1 (2) TO ANML-GRZG-CD2-3929-VL-S1.
  18464. 043400     MOVE ANML-EST-POP-3926-VL-I1 (1) TO ANML-EST-POP1-3926-VL-S1.
  18465. 043500     MOVE ANML-EST-POP-3926-VL-I1 (2) TO
  18466. 043600          ANML-EST-POP2-3926-VL-S1.
  18467. 043700     MOVE USE-MO-DT-FR-3845-VL-I1 (1) TO
  18468. 043800          USE-MO-DT-FR-3845-VL-S1 (1).
  18469. 043900     MOVE USE-MO-DT-FR-3845-VL-I1 (2) TO
  18470. 044000             USE-MO-DT-FR-3845-VL-S1 (2).
  18471. 044100     MOVE USE-DD-DT-FR-3845-VL-I1 (1) TO
  18472. 044200           USE-DD-DT-FR-3845-VL-S1 (1).
  18473. 044300     MOVE USE-DD-DT-FR-3845-VL-I1 (2) TO
  18474. 044400          USE-DD-DT-FR-3845-VL-S1 (2).
  18475. 044500     MOVE USE-MO-DT-TO-3845-VL-I1 (1) TO
  18476. 044600          USE-MO-DT-TO-3845-VL-S1 (1).
  18477. 044700     MOVE USE-MO-DT-TO-3845-VL-I1 (2) TO
  18478. 044800          USE-MO-DT-TO-3845-VL-S1 (2).
  18479. 044900     MOVE USE-DD-DT-TO-3845-VL-I1 (1) TO
  18480. 045000          USE-DD-DT-TO-3845-VL-S1 (1).
  18481. 045100     MOVE USE-DD-DT-TO-3845-VL-I1 (2) TO
  18482. 045200          USE-DD-DT-TO-3845-VL-S1 (2).
  18483. 045300     RELEASE S-KEY1.
  18484. 045400 750-EXIT-VL.
  18485. 045500     EXIT.
  18486. 045600 800-MV-VW-TO-SRT.
  18487. 045700     ADD 1 TO VW-CNT.
  18488. 045800     MOVE REC-TYPE-3529-VW-I1  TO  REC-TYPE-3529-VW-S1.
  18489. 045900     MOVE FMT-NO-3576-VW-I1  TO  FMT-NO-3576-VW-S1.
  18490. 046000     MOVE FMT-CD-3579-VW-I1  TO  FMT-CD-3579-VW-S1.
  18491. 046100     MOVE ADM-UNIT-0003-VW-I1  TO  ADM-UNIT-0003-VW-S1.
  18492. 046200     MOVE DATA-DT-6618-VW-I1  TO  DATA-DT-6618-VW-S1.
  18493. 046300     MOVE ACT-CD-7350-VW-I1  TO  ACT-CD-7350-VW-S1.
  18494. 046400     MOVE LINE-NO-3578-VW-I1 TO   LINE-NO-3578-VW-S1.
  18495. 046500     MOVE HERD-UNIT-NUM-6598-VW-I1 TO HERD-UNIT-NUM-6598-VW-S1.
  18496. 046600     MOVE ALLOT-NUM-0968-VW-I1  TO ALLOT-NUM-0968-VW-S1.
  18497. 046700     MOVE HERD-UNIT-ALLOT-PCT-3927-VW-I1  TO
  18498. 046800                       HERD-UNIT-ALLOT-PCT-3927-VW-S1.
  18499. 046900     MOVE ANML-GRZG-CD-3929-VW-I1 TO ANML-GRZG-CD-3929-VW-S1.
  18500. 047000     MOVE ANML-EST-POP-3926-VW-I1 TO ANML-EST-POP-3926-VW-S1.
  18501. 047100     MOVE USE-DATES-3845-VW-I1   TO USE-DATES-3845-VW-S1.
  18502. 047200     MOVE SWA-3507-VW-I1(1) TO SWA-3507-VW-S1(1).
  18503. 047300     MOVE SWA-3507-VW-I1(2) TO SWA-3507-VW-S1(2).
  18504. 047400     MOVE SWA-3507-VW-I1(3) TO SWA-3507-VW-S1(3).
  18505. 047500     MOVE SWA-3507-VW-I1(4) TO SWA-3507-VW-S1(4).
  18506. 047600     MOVE SWA-3507-VW-I1(5) TO SWA-3507-VW-S1(5).
  18507. 047700     RELEASE S-KEY2.
  18508. 047800 850-EXIT-VW.
  18509. 047900     EXIT.
  18510. 048000 POST-SORT SECTION.
  18511. 048100 3050-RET-HSKPNG.
  18512. 048200     OPEN OUTPUT PRINT-FILE.
  18513. 048300     ACCEPT  PARAMETER.
  18514. 048400     ACCEPT  HOLD-DT FROM DATE.
  18515. 048500     MOVE YR-DT TO HDR-YR.
  18516. 048600     MOVE MON(MO-DT) TO HDR-MO.
  18517. 048700     MOVE DY-DT TO HDR-DA.
  18518. 048800     READY DIC-DE.
  18519. 048900     PERFORM 4000-VALIDATE-INV THRU 4050-EXIT-STDI.
  18520. 049000     RETURN  SORT-FILE AT END MOVE 1 TO EOR-SWITCH.
  18521. 049100     MOVE REC-TYPE-3529-VL-S1  TO HLD-REC-TYPE.
  18522. 049200     PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
  18523. 049300 3070-MAIN-DRIVER.
  18524. 049400     PERFORM 4300-DET-REC-LINE THRU 4350-EXIT-DET UNTIL EOR.
  18525. 049500     IF (EOR-SWITCH = 1) GO TO 5000-DUMMY.
  18526. 049600 4000-VALIDATE-INV.
  18527. 049700     MOVE PARAMETER TO DE-CD-8822-DEC  HDR-INV-CD.
  18528. 049800     MOVE 3940 TO DE-NO-8801-DEC.
  18529. 049900     FIND ANY CODE-DEC.
  18530. 050000     MOVE DB-STATUS TO DB-STAT.
  18531. 050100     IF  NOT OK
  18532. 050200         MOVE "UNKNOWN" TO HDR-ST-NM HDR-DIST-NM HDR-INV-NM
  18533. 050300         GO  TO 4050-EXIT-STDI.
  18534. 050400     GET CODE-DEC.
  18535. 050500     MOVE DB-STATUS TO DB-STAT.
  18536. 050600     IF  NOT OK
  18537. 050700         DISPLAY "ES415PBD   DIDN'T GET INVN"
  18538. 050800         DISPLAY DB-STAT
  18539. 050900         GO  TO 4050-EXIT-STDI.
  18540. 051000     MOVE DE-CD-NAM-8823-DEC TO INV-HLD.
  18541. 051100     MOVE INV-NM TO HDR-INV-NM.
  18542. 051200 4005-VALIDATE-ST.
  18543. 051300     MOVE ST-CD-HLD TO DE-CD-8822-DEC  HDR-ST-CD.
  18544. 051400     MOVE 0003 TO DE-NO-8801-DEC.
  18545. 051500     FIND ANY CODE-DEC.
  18546. 051600     MOVE DB-STATUS TO DB-STAT.
  18547. 051700     IF NOT OK
  18548. 051800         MOVE "UNKNOWN" TO HDR-ST-NM
  18549. 051900         GO TO 4008-EXIT-ST.
  18550. 052000     GET CODE-DEC.
  18551. 052100     MOVE DB-STATUS TO DB-STAT.
  18552. 052200     IF NOT OK
  18553. 052300         DISPLAY "ES415PBD  3  DIDN'T GET ST"
  18554. 052400         DISPLAY "ES415PBD  4  " DB-STAT
  18555. 052500         GO TO 4008-EXIT-ST.
  18556. 052600     MOVE DE-CD-NAM-8823-DEC TO FUNC-HLD.
  18557. 052700     MOVE ST-NM-HLD TO HDR-ST-NM.
  18558. 052800 4008-EXIT-ST.
  18559. 052900     EXIT.
  18560. 053000 4010-VALIDATE-STDI.
  18561. 053100     MOVE ST-DIST-CD TO DE-CD-8822-DEC.
  18562. 053200     MOVE DI-CD-HLD TO HDR-DIST-CD.
  18563. 053300     MOVE 0003 TO DE-NO-8801-DEC.
  18564. 053400     FIND ANY CODE-DEC.
  18565. 053500     MOVE DB-STATUS TO DB-STAT.
  18566. 053600     IF  NOT OK
  18567. 053700         MOVE "UNKNOWN" TO HDR-DIST-NM
  18568. 053800         GO  TO 4050-EXIT-STDI.
  18569. 053900     GET CODE-DEC.
  18570. 054000     MOVE DB-STATUS TO DB-STAT.
  18571. 054100     IF  NOT OK
  18572. 054200         DISPLAY "ES415PBD 5 DIDN'T GET STDI"
  18573. 054300         DISPLAY  "ES415PBD 6 " DB-STAT
  18574. 054400         GO  TO 4050-EXIT-STDI.
  18575. 054500     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  18576. 054600     MOVE DB-STATUS TO DB-STAT.
  18577. 054700     IF  NOT OK
  18578. 054800         MOVE "UNKNOWN" TO HDR-DIST-NM
  18579. 054900         GO  TO 4050-EXIT-STDI.
  18580. 055000     GET CODE-EXPL-DECE.
  18581. 055100     MOVE DB-STATUS TO DB-STAT.
  18582. 055200     IF  NOT OK
  18583. 055300         DISPLAY "ES415PBD  7 DIDN'T GET DIST"
  18584. 055400         DISPLAY  "ES415PBD 8  " DB-STAT
  18585. 055500         GO  TO 4050-EXIT-STDI.
  18586. 055600     MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HLD
  18587. 055700     MOVE DIST-NM-HLD TO HDR-DIST-NM.
  18588. 055800 4050-EXIT-STDI.
  18589. 055900     EXIT.
  18590. 056000 4100-CHK-LINE-CNT.
  18591. 056100     IF  LINE-CNT > 50
  18592. 056200         PERFORM 4200-PRT-HDNG THRU 4250-HDNG-EXIT
  18593. 056300         GO  TO 4150-EXIT-LINE-OVR50.
  18594. 056400 4150-EXIT-LINE-OVR50.
  18595. 056500     EXIT.
  18596. 056600 4200-PRT-HDNG.
  18597. 056700     ADD 1 TO PAGE-CNT.
  18598. 056800     MOVE PAGE-CNT TO HDR-PG.
  18599. 056900     WRITE PRT-REC FROM HDR-1 AFTER ADVANCING PAGE.
  18600. 057000     WRITE PRT-REC FROM HDR-2 AFTER ADVANCING 1 LINES.
  18601. 057100     WRITE PRT-REC FROM HDR-3 AFTER ADVANCING 1 LINES.
  18602. 057200     MOVE 2 TO LINE-CNT.
  18603. 057300 4220-CHK-WHAT-REC.
  18604. 057400     IF  HLD-REC-TYPE = "VL"
  18605. 057500         MOVE "VL" TO HDR-REC-TYPE
  18606. 057600         WRITE PRT-REC FROM HDR-4  AFTER ADVANCING 1 LINES
  18607. 057700         WRITE PRT-REC FROM HDR-5-VL AFTER ADVANCING 2 LINES
  18608. 057800         WRITE PRT-REC FROM HDR-6-VL AFTER ADVANCING 1 LINES
  18609. 057900         WRITE PRT-REC FROM HDR-7-VL AFTER ADVANCING 1 LINES
  18610. 058000         WRITE PRT-REC FROM HDR-8-VL AFTER ADVANCING 1 LINES
  18611. 058100         WRITE PRT-REC FROM HDR-9-VL AFTER ADVANCING 1 LINES
  18612. 058200         GO TO 4230-PRT-SPACES.
  18613. 058300     IF  HLD-REC-TYPE = "VW"
  18614. 058400         MOVE "VW" TO HDR-REC-TYPE
  18615. 058500         WRITE PRT-REC FROM HDR-4 AFTER ADVANCING 1 LINES
  18616. 058600         WRITE PRT-REC FROM HDR-5-VW AFTER ADVANCING 2 LINES
  18617. 058700         WRITE PRT-REC FROM HDR-6-VW AFTER ADVANCING 1 LINES
  18618. 058800         WRITE PRT-REC FROM HDR-7-VW AFTER ADVANCING 1 LINES
  18619. 058900         WRITE PRT-REC FROM HDR-8-VW AFTER ADVANCING 1 LINES
  18620. 059000         WRITE PRT-REC FROM HDR-9-VW AFTER ADVANCING 1 LINES
  18621. 059100         GO TO 4230-PRT-SPACES.
  18622. 059200 4230-PRT-SPACES.
  18623. 059300     MOVE SPACES TO PRT-REC.
  18624. 059400     WRITE PRT-REC AFTER ADVANCING 1 LINES.
  18625. 059500     ADD 7 TO LINE-CNT.
  18626. 059600 4250-HDNG-EXIT.
  18627. 059700     EXIT.
  18628. 059800 4300-DET-REC-LINE.
  18629. 059900     IF  REC-TYPE-3529-VL-S1 = HLD-REC-TYPE
  18630. 060000         PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP
  18631. 060100         GO  TO 4320-RET-SORT.
  18632. 060200     IF  REC-TYPE-3529-VL-S1 = "99"  GO TO 4350-EXIT-DET.
  18633. 060300     MOVE 66 TO LINE-CNT.
  18634. 060400     MOVE 0 TO PAGE-CNT.
  18635. 060500     MOVE REC-TYPE-3529-VL-S1 TO HLD-REC-TYPE.
  18636. 060600     PERFORM 4400-PRNT-DET-LINE THRU 4450-EXIT-CHK-REC-TYP.
  18637. 060700 4320-RET-SORT.
  18638. 060800     RETURN SORT-FILE AT END MOVE 1 TO EOR-SWITCH
  18639. 060900        MOVE "99" TO REC-TYPE-3529-VL-S1.
  18640. 061000     IF EOR-SWITCH = 1 GO TO 4350-EXIT-DET.
  18641. 061100 4350-EXIT-DET.
  18642. 061200     EXIT.
  18643. 061300 4400-PRNT-DET-LINE.
  18644. 061400     PERFORM 4100-CHK-LINE-CNT THRU 4150-EXIT-LINE-OVR50.
  18645. 061500     IF  REC-TYPE-3529-VL-S1 = "VL"
  18646. 061600     PERFORM 4500-PRNT-VL THRU 4800-EXIT-PRT-DET
  18647. 061700     GO  TO  4450-EXIT-CHK-REC-TYP.
  18648. 061800     IF  REC-TYPE-3529-VW-S1 = "VW"
  18649. 061900         PERFORM 4550-PRNT-VW THRU 4800-EXIT-PRT-DET
  18650. 062000         GO  TO 4450-EXIT-CHK-REC-TYP.
  18651. 062100 4450-EXIT-CHK-REC-TYP.
  18652. 062200     EXIT.
  18653. 062300 4500-PRNT-VL.
  18654. 062400     MOVE REC-TYPE-3529-VL-S1  TO REC-TYPE-3529-VL-P1.
  18655. 062500     MOVE FMT-NO-3576-VL-S1 TO    FMT-NO-3576-VL-P1.
  18656. 062600     MOVE FMT-CD-3579-VL-S1 TO    FMT-CD-3579-VL-P1.
  18657. 062700     MOVE ADM-ST-0003-VL-S1 TO    ADM-ST-0003-VL-P1.
  18658. 062800     MOVE ADM-DI-0003-VL-S1 TO    ADM-DI-0003-VL-P1.
  18659. 062900     MOVE ADM-RA-0003-VL-S1 TO    ADM-RA-0003-VL-P1.
  18660. 063000     MOVE ADM-PU-0003-VL-S1 TO    ADM-PU-0003-VL-P1.
  18661. 063100     MOVE DATA-DT-6618-VL-S1 TO   DATA-DT-6618-VL-P1.
  18662. 063200     MOVE ACT-CD-7350-VL-S1 TO    ACT-CD-7350-VL-P1.
  18663. 063300     MOVE LINE-NO-3578-VL-S1  TO  LINE-NO-3578-VL-P1.
  18664. 063400     MOVE ALLOT-NUM1-0968-VL-S1  TO  ALLOT-NUM1-0968-VL-P1.
  18665. 063500     MOVE ALLOT-NUM2-0968-VL-S1  TO  ALLOT-NUM2-0968-VL-P1.
  18666. 063600     MOVE PASTURE-NUM1-3905-VL-S1  TO  PASTURE-NUM1-3905-VL-P1.
  18667. 063700     MOVE PASTURE-NUM2-3905-VL-S1  TO  PASTURE-NUM2-3905-VL-P1.
  18668. 063800     MOVE ANML-GRZG-CD1-3929-VL-S1 TO  ANML-GRZG-CD1-3929-VL-P1.
  18669. 063900     MOVE ANML-GRZG-CD2-3929-VL-S1  TO ANML-GRZG-CD2-3929-VL-P1.
  18670. 064000     MOVE ANML-EST-POP1-3926-VL-S1 TO ANML-EST-POP1-3926-VL-P1.
  18671. 064100     MOVE ANML-EST-POP2-3926-VL-S1 TO ANML-EST-POP2-3926-VL-P1.
  18672. 064200     MOVE USE-MO-DT-FR-3845-VL-S1 (1) TO USE-MO-DT-FR1-3845-VL-P1.
  18673. 064300     MOVE USE-MO-DT-FR-3845-VL-S1 (2) TO USE-MO-DT-FR2-3845-VL-P1.
  18674. 064400     MOVE USE-DD-DT-FR-3845-VL-S1 (1) TO USE-DD-DT-FR1-3845-VL-P1.
  18675. 064500     MOVE USE-DD-DT-FR-3845-VL-S1 (2) TO USE-DD-DT-FR2-3845-VL-P1.
  18676. 064600     MOVE USE-MO-DT-TO-3845-VL-S1 (1) TO USE-MO-DT-TO1-3845-VL-P1.
  18677. 064700     MOVE USE-MO-DT-TO-3845-VL-S1 (2) TO USE-MO-DT-TO2-3845-VL-P1.
  18678. 064800     MOVE USE-DD-DT-TO-3845-VL-S1 (1) TO USE-DD-DT-TO1-3845-VL-P1.
  18679. 064900     MOVE USE-DD-DT-TO-3845-VL-S1 (2) TO USE-DD-DT-TO2-3845-VL-P1.
  18680. 065000     WRITE PRT-REC FROM HDR-10-DET-VL AFTER ADVANCING 2 LINES.
  18681. 065100     ADD 2 TO LINE-CNT.
  18682. 065200     GO  TO 4800-EXIT-PRT-DET.
  18683. 065300 4550-PRNT-VW.
  18684. 065400     MOVE REC-TYPE-3529-VW-S1 TO  REC-TYPE-3529-VW-P1.
  18685. 065500     MOVE FMT-NO-3576-VW-S1 TO    FMT-NO-3576-VW-P1.
  18686. 065600     MOVE FMT-CD-3579-VW-S1 TO    FMT-CD-3579-VW-P1.
  18687. 065700     MOVE ADM-ST-0003-VW-S1 TO    ADM-ST-0003-VW-P1.
  18688. 065800     MOVE ADM-DI-0003-VW-S1 TO    ADM-DI-0003-VW-P1.
  18689. 065900     MOVE ADM-RA-0003-VW-S1 TO    ADM-RA-0003-VW-P1.
  18690. 066000     MOVE ADM-PU-0003-VW-S1 TO    ADM-PU-0003-VW-P1.
  18691. 066100     MOVE DATA-DT-6618-VW-S1 TO   DATA-DT-6618-VW-P1.
  18692. 066200     MOVE ACT-CD-7350-VW-S1 TO    ACT-CD-7350-VW-P1.
  18693. 066300     MOVE LINE-NO-3578-VW-S1 TO   LINE-NO-3578-VW-P1.
  18694. 066400     MOVE HERD-UNIT-NUM-6598-VW-S1 TO HERD-UNIT-NUM-6598-VW-P1.
  18695. 066500     MOVE ALLOT-NUM-0968-VW-S1 TO ALLOT-NUM-0968-VW-P1.
  18696. 066600     MOVE HERD-UNIT-ALLOT-PCT-3927-VW-S1 TO
  18697. 066700             HERD-UNIT-ALLOT-PCT-3927-VW-P1.
  18698. 066800     MOVE ANML-GRZG-CD-3929-VW-S1 TO ANML-GRZG-CD-3929-VW-P1.
  18699. 066900     MOVE ANML-EST-POP-3926-VW-S1 TO ANML-EST-POP-3926-VW-P1.
  18700. 067000     MOVE USE-MO-DT-FR-3845-VW-S1 TO USE-MO-DT-FR-3845-VW-P1.
  18701. 067100     MOVE USE-DD-DT-FR-3845-VW-S1 TO USE-DD-DT-FR-3845-VW-P1.
  18702. 067200     MOVE USE-MO-DT-TO-3845-VW-S1 TO USE-MO-DT-TO-3845-VW-P1.
  18703. 067300     MOVE USE-DD-DT-TO-3845-VW-S1 TO USE-DD-DT-TO-3845-VW-P1.
  18704. 067400     MOVE SWA-3507-VW-S1 (1) TO SWA1-3507-VW-P1.
  18705. 067500     MOVE SWA-3507-VW-S1 (2) TO SWA2-3507-VW-P1.
  18706. 067600     MOVE SWA-3507-VW-S1 (3) TO SWA3-3507-VW-P1.
  18707. 067700     MOVE SWA-3507-VW-S1 (4) TO SWA4-3507-VW-P1.
  18708. 067800     MOVE SWA-3507-VW-S1 (5) TO SWA5-3507-VW-P1.
  18709. 067900     WRITE PRT-REC FROM HDR-10-DET-VW AFTER ADVANCING 2 LINES.
  18710. 068000     ADD 2 TO LINE-CNT.
  18711. 068100 4800-EXIT-PRT-DET.
  18712. 068200     EXIT.
  18713. 068300 DUMMY-SECTION.
  18714. 068400 5000-DUMMY.
  18715. 068500     EXIT.
  18716. 068600 END-OF-JOB.
  18717. 000000*-----------------------------------------------------------------
  18718. 000100 IDENTIFICATION DIVISION.
  18719. 000200 PROGRAM-ID. ES420E.
  18720. 000300*        EDIT/UPDATE OF LIVESTOCK (VL) AND
  18721. 000400*            WILDLIFE (VW) USE DATA.
  18722. 000500 AUTHOR. FRANK WILEY.
  18723. 000600 DATE-WRITTEN.  20 AUG 79.
  18724. 000700 DATE-COMPILED.
  18725. 000800 ENVIRONMENT DIVISION.
  18726. 000900 CONFIGURATION SECTION.
  18727. 001000 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  18728. 001100 OBJECT-COMPUTER.  LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
  18729. 001200 INPUT-OUTPUT SECTION.
  18730. 001300 FILE-CONTROL.
  18731. 001400     SELECT VL-VW-OUT ASSIGN TO D1
  18732. 001500          ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  18733. 001600     SELECT VL-VW-IN ASSIGN TO I1
  18734. 001700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  18735. 001800    SELECT PRINT-FILE ASSIGN TO P1
  18736. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  18737. 002000 DATA DIVISION.
  18738. 002100 SUB-SCHEMA SECTION.
  18739. 002200 DB  CODVAL2 WITHIN BLMDIC.
  18740. 002300 FILE SECTION.
  18741. 002400 FD  VL-VW-IN
  18742. 002500     CODE-SET IS GBCD
  18743. 002600     LABEL RECORDS ARE STANDARD.
  18744. 002700 01  VW-RCD.
  18745. 002800     03  RECORD-FORMAT.
  18746. 002900          05  REC-TYP-W                    PIC XX.
  18747. 003000          05  FMT-NUM-W                    PIC X.
  18748. 003100          05  FMT-CD-W                     PIC X.
  18749. 003200     03  BLM-ADM-IN.
  18750. 003300         05  BLM-ADM-4.
  18751. 003400             07  BLM-ADM-3.
  18752. 003500                 09  BLM-ADM-2.
  18753. 003600                     11  BLM-ADM-ST-W            PIC XX.
  18754. 003700                     11  BLM-ADM-DIST-W          PIC XX.
  18755. 003800                 09  BLM-ADM-RA-W                PIC XX.
  18756. 003900             07  BLM-ADM-PLU-W                   PIC XX.
  18757. 004000     03  DATA-DATE-W                             PIC X(6).
  18758. 004100     03  ACTN-CD-W                               PIC X.
  18759. 004200     03  LIN-NUM-W                    PIC X(4).
  18760. 004300     03  HERD-UNIT-NUM-W              PIC X(8).
  18761. 004400     03  ALLOT-NUM-W                  PIC X(4).
  18762. 004500     03  HERD-UNIT-ALLOT-PCT           PIC X(3).
  18763. 004600     03  ANML-GRZG-CD-W               PIC XX.
  18764. 004700     03  ANML-EST-POP-W               PIC X(5).
  18765. 004800     03  USE-DATES.
  18766. 004900        05  USE-DATES1ST.
  18767. 005000            07  USE-DATES1ST-MON     PIC 9(2).
  18768. 005100                88  MON-1-W  VALUES 1 THRU 12.
  18769. 005200            07  USE-DATES1ST-DAY     PIC 9(2).
  18770. 005300                88  DAY-1-W  VALUES 1 THRU 31.
  18771. 005400        05  USE-DATESEND.
  18772. 005500            07  USE-DATESEND-MON     PIC 9(2).
  18773. 005600                88  MON-2-W  VALUES 1 THRU 12.
  18774. 005700            07  USE-DATESEND-DAY     PIC 9(2).
  18775. 005800                88  DAY-2-W  VALUES 1 THRU 31.
  18776. 005900     03  SWA-GRP.
  18777. 006000         05  SWA-SET        OCCURS 5.
  18778. 006100            07  SWACD-W             PIC X.
  18779. 006200            07  SWA-THREE            PIC X(3).
  18780. 006300     03  FILLER                       PIC X(5).
  18781. 006400 01 VL-RCD.
  18782. 006500     03  FILLER                        PIC X(23).
  18783. 006600     03  HERD-GRP    OCCURS 2.
  18784. 006700         05  ALOT-VL   PIC XXXX.
  18785. 006800         05  FILLER    PIC X(17).
  18786. 006900     03  FILLER                        PIC X(12).
  18787. 007000 FD  PRINT-FILE
  18788. 007100     CODE-SET IS GBCD
  18789. 007200     LABEL RECORDS ARE STANDARD
  18790. 007300     DATA RECORD IS PRINT-RCD.
  18791. 007400 01  PRINT-RCD                         PIC X(132).
  18792. 007500 FD VL-VW-OUT
  18793. 007600      CODE-SET IS GBCD
  18794. 007700     LABEL RECORD IS STANDARD
  18795. 007800     DATA RECORD VI-OUT-RCD.
  18796. 007900 01  VL-VW-RCD                          PIC X(78).
  18797. 008000 WORKING-STORAGE SECTION.
  18798. 008100 77  ERROR-SW     COMP-4                PIC 9 VALUE ZERO.
  18799. 008200 77  PAGE-NO      COMP-4                PIC 9(6) VALUE 0.
  18800. 008300 77  HDR-SW1      COMP-4                PIC 9 VALUE ZERO.
  18801. 008400 77  HDR-SW2      COMP-4                PIC 9 VALUE ZERO.
  18802. 008500 77  LINE-CNT     COMP-4                PIC 99 VALUE ZERO.
  18803. 008600 77  HDR-SW3      COMP-4                PIC 9 VALUE ZERO.
  18804. 008700 77  PAGE-SW      COMP-4                PIC 9 VALUE 1.
  18805. 008800 77  PROCESS-SW   COMP-4                PIC 9 VALUE ZERO.
  18806. 008900 01  BLM-ADM-HOLD.
  18807. 009000         05  ST-HOLD                    PIC XX.
  18808. 009100         05  DT-HOLD                    PIC XX.
  18809. 009200         05  RA-HOLD                    PIC XX.
  18810. 009300         05  PLU-HOLD                   PIC XX.
  18811. 009400 01  DATE-HOLD.
  18812. 009500     03  YEAR-H                         PIC 99.
  18813. 009600     03  MON-H                          PIC 99.
  18814. 009700     03  DAY-H                          PIC 99.
  18815. 009800 01  MONTH-TABLE                        PIC X(36) VALUE
  18816. 009900     "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC".
  18817. 010000 01  MONTH-LINE REDEFINES MONTH-TABLE.
  18818. 010100     03  ALPHA-MONTH                    PIC X(3) OCCURS 12.
  18819. 010200 01  HOLD-AREA.
  18820. 010300     03  FUNC-HOLD.
  18821. 010400         04  STATE-NAME                 PIC X(10).
  18822. 010500         04  FILLER                     PIC X(14).
  18823. 010600     03  EXPL-HOLD.
  18824. 010700         04  DIST-NAME                  PIC X(10).
  18825. 010800         04  FILLER                     PIC X.
  18826. 010900         04  RA-NAME                    PIC X(12).
  18827. 011000         04  FILLER                     PIC X.
  18828. 011100         04  PLU-NAME                   PIC X(15).
  18829. 011200         04  FILLER                     PIC X.
  18830. 011300     03  DIST-H                         PIC XX.
  18831. 011400     COPY DBSTATUS OF TPCOBOLIB.
  18832. 011500 01  HDR-1.
  18833. 011600     03  FILLER                    PIC X(8) VALUE
  18834. 011700         "    PCN ".
  18835. 011800     03  FILLER                    PIC X(10) VALUE "ES420E    ".
  18836. 011900     03  FILLER                    PIC X(6) VALUE "AS OF ".
  18837. 012000     03  DATE-AS-OF.
  18838. 012100         04  DD                    PIC 99.
  18839. 012200         04  FILLER                PIC X VALUE SPACE.
  18840. 012300         04  MMM                   PIC XXX.
  18841. 012400         04  FILLER                PIC X VALUE SPACE.
  18842. 012500         04  YY                    PIC 99.
  18843. 012600     03  FILLER                    PIC X(09) VALUE SPACE.
  18844. 012700     03  FILLER                    PIC X(48) VALUE
  18845. 012800         "USDI- BUR OF LAND MGT  ECOLOGICAL SITE INVENTORY".
  18846. 012900     03  FILLER                    PIC X(28) VALUE SPACE.
  18847. 013000     03  FILLER                    PIC X(7) VALUE "PAGE   ".
  18848. 013100     03  PAGE-CNT                  PIC Z,ZZ9.
  18849. 013200     03  FILLER                    PIC X(02) VALUE SPACE.
  18850. 013300 01  HDR-2.
  18851. 013400     03  FILLER                   PIC X(17) VALUE SPACE.
  18852. 013500     03  FILLER                   PIC X(8) VALUE "STATE   ".
  18853. 013600     03  ST-HDR                   PIC X(15).
  18854. 013700     03  FILLER                   PIC X(16) VALUE SPACE.
  18855. 013800     03  FILLER                   PIC X(7) VALUE "DIST   ".
  18856. 013900     03  DIST-HDR                 PIC X(15).
  18857. 014000     03  FILLER                   PIC X(15) VALUE SPACE.
  18858. 014100     03  VL-VW-TYPE               PIC XX VALUE "VL".
  18859. 014200     03  FILLER                   PIC X(20) VALUE
  18860. 014300          "  EDIT ERROR LISTING".
  18861. 014400     03  FILLER                   PIC X(17) VALUE SPACE.
  18862. 014500 01  HDR-3.
  18863. 014600     03  FILLER                   PIC X(40) VALUE
  18864. 014700          "               REC TYP            ST    ".
  18865. 014800     03  FILLER                   PIC X(40) VALUE
  18866. 014900          "        DIST            RA              ".
  18867. 015000     03  FILLER                   PIC X(40) VALUE
  18868. 015100          "PLU              DATE            ACTN   ".
  18869. 015200     03  FILLER                   PIC X(12) VALUE SPACE.
  18870. 015300 01  HDR-4.
  18871. 015400     03  FILLER                   PIC X(17) VALUE SPACE.
  18872. 015500     03  FILLER                   PIC X(43) VALUE
  18873. 015600          "1-4             5-6             7-8        ".
  18874. 015700     03  FILLER                   PIC X(41) VALUE
  18875. 015800          "   9-10            11-12            13-18".
  18876. 015900     03  FILLER                   PIC X(31) VALUE
  18877. 016000         "             19                ".
  18878. 016100 01  HDR-5.
  18879. 016200     03  FILLER                   PIC X(17) VALUE SPACE.
  18880. 016300     03  FILLER                   PIC X(43) VALUE
  18881. 016400          "XXXX             XX              XX        ".
  18882. 016500     03  FILLER                   PIC X(43) VALUE
  18883. 016600          "    XX               XX             XXXXXX ".
  18884. 016700     03  FILLER                   PIC X(29) VALUE
  18885. 016800          "            X                ".
  18886. 016900 01  HDR-6L.
  18887. 017000     03  FILLER                   PIC X(40) VALUE
  18888. 017100         "   LIN NUM  ALLOT   PASTURE   ANML SP   ".
  18889. 017200     03  FILLER                   PIC X(40) VALUE
  18890. 017300         "AUTH/LSTK  FROM DATE  TO DATE  ALLOT   P".
  18891. 017400     03  FILLER                   PIC X(40) VALUE
  18892. 017500         "ASTURE   ANML SP   AUTH/LSTK  FROM DATE ".
  18893. 017600     03  FILLER                   PIC X(12) VALUE
  18894. 017700         " TO DATE    ".
  18895. 017800 01  HDR-7L.
  18896. 017900     03  FILLER                   PIC X(40) VALUE
  18897. 018000         "    20-23   24-27    28-29     30-31    ".
  18898. 018100     03  FILLER                   PIC X(40) VALUE
  18899. 018200         "  32-36      37-40     41-44   45-48    ".
  18900. 018300     03  FILLER                   PIC X(40) VALUE
  18901. 018400         "49-50     51-52      53-57      58-61   ".
  18902. 018500     03  FILLER                   PIC X(12) VALUE
  18903. 018600         "  62-65     ".
  18904. 018700 01  HDR-8L.
  18905. 018800     03  FILLER                   PIC X(40) VALUE
  18906. 018900         "     XXXX    XXXX      XX        XX     ".
  18907. 019000     03  FILLER                   PIC X(40) VALUE
  18908. 019100         "  XXXXX      XX/XX     XX/XX    XXXX    ".
  18909. 019200     03  FILLER                   PIC X(40) VALUE
  18910. 019300         "  XX        XX       XXXXX      XX/XX   ".
  18911. 019400     03  FILLER                   PIC X(12) VALUE
  18912. 019500         "  XX/XX     ".
  18913. 019600 01  HDR-9W.
  18914. 019700     03  FILLER                   PIC X(40) VALUE
  18915. 019800         "   LIN NUM    HRD NO   ALLOT    % HRD   ".
  18916. 019900     03  FILLER                   PIC X(45) VALUE
  18917. 020000         " ANML SP    EST NUM ANML   FROM DATE  TO DATE".
  18918. 020100     03  FILLER                   PIC X(39) VALUE
  18919. 020200         "   SWA    SWA    SWA    SWA    SWA     ".
  18920. 020300     03  FILLER                   PIC X(8) VALUE SPACE.
  18921. 020400 01  HDR-10W.
  18922. 020500     03  FILLER                   PIC X(40) VALUE
  18923. 020600         "    20-23      24-31   32-35    36-38   ".
  18924. 020700     03  FILLER                   PIC X(45) VALUE
  18925. 020800         "  39-40        41-45         46-49     50-53 ".
  18926. 020900     03  FILLER                   PIC X(39) VALUE
  18927. 021000         "  54-57  58-61  62-65  66-69  70-73    ".
  18928. 021100     03  FILLER                   PIC X(8) VALUE SPACE.
  18929. 021200 01  HDR-11W.
  18930. 021300     03  FILLER                   PIC X(40) VALUE
  18931. 021400         "     XXXX    XXXXXXXX   XXXX     XXX    ".
  18932. 021500     03  FILLER                   PIC X(45) VALUE
  18933. 021600         "    XX         XXXXX         XX/XX     XX/XX ".
  18934. 021700     03  FILLER                   PIC X(39) VALUE
  18935. 021800         "   XXXX   XXXX   XXXX   XXXX   XXXX    ".
  18936. 021900     03  FILLER                   PIC X(8) VALUE SPACE.
  18937. 022000 01  PRINT-1LW.
  18938. 022100     03  FILLER                   PIC X(17) VALUE SPACE.
  18939. 022200     03  REC-TYP-P                PIC X(4).
  18940. 022300     03  FILLER                   PIC X(13) VALUE SPACE.
  18941. 022400     03  BLM-ADM-ST               PIC XX.
  18942. 022500     03  FILLER                   PIC X(14) VALUE SPACE.
  18943. 022600     03  BLM-ADM-DIST             PIC XX.
  18944. 022700     03  FILLER                   PIC X(12) VALUE SPACE.
  18945. 022800     03  BLM-ADM-RA               PIC XX.
  18946. 022900     03  FILLER                   PIC X(15) VALUE SPACE.
  18947. 023000     03  BLM-ADM-PLU              PIC XX.
  18948. 023100     03  FILLER                   PIC X(13) VALUE SPACE.
  18949. 023200     03  DATA-DATE-P              PIC X(6).
  18950. 023300     03  FILLER                   PIC X(13) VALUE SPACE.
  18951. 023400     03  ACTN-CD-P                PIC X.
  18952. 023500     03  FILLER                   PIC X(16) VALUE SPACE.
  18953. 023600 01  PRINT-2LW.
  18954. 023700     03  FILLER                   PIC X(17) VALUE SPACE.
  18955. 023800     03  ASTER-1                  PIC X(4).
  18956. 023900     03  FILLER                   PIC X(13) VALUE SPACE.
  18957. 024000     03  ASTER-2                  PIC XX.
  18958. 024100     03  FILLER                   PIC X(14) VALUE SPACE.
  18959. 024200     03  ASTER-3                  PIC XX.
  18960. 024300     03  FILLER                   PIC X(12) VALUE SPACE.
  18961. 024400     03  ASTER-4                  PIC XX.
  18962. 024500     03  FILLER                   PIC X(15) VALUE SPACE.
  18963. 024600     03  ASTER-5                  PIC XX.
  18964. 024700     03  FILLER                   PIC X(49) VALUE SPACE.
  18965. 024800 01  PRINT-3L.
  18966. 024900     03  FILLER                   PIC X(5) VALUE SPACE.
  18967. 025000     03  LIN-NUM-P1                PIC X(4).
  18968. 025100     03  FILLER                   PIC X(4) VALUE SPACE.
  18969. 025200     03  ALLOT-NUM-P1              PIC X(4).
  18970. 025300     03  FILLER                   PIC X(6) VALUE SPACE.
  18971. 025400     03  PASTURE-NUM-P1            PIC XX.
  18972. 025500     03  FILLER                   PIC X(8) VALUE SPACE.
  18973. 025600     03  ANML-GRZG-CD-P1          PIC XX.
  18974. 025700     03  FILLER                   PIC X(7) VALUE SPACE.
  18975. 025800     03  ANML-EST-POP-P1           PIC X(5).
  18976. 025900     03  FILLER                   PIC X(6) VALUE SPACE.
  18977. 026000     03  USE-DATE-FROM.
  18978. 026100         05  F-MM-1                 PIC XX.
  18979. 026200         05  FILLER               PIC X VALUE SPACE.
  18980. 026300         05  F-DD-1                 PIC XX.
  18981. 026400     03  FILLER                   PIC X(5) VALUE SPACE.
  18982. 026500     03  USE-DATE-TO.
  18983. 026600          05  T-MM-1                  PIC XX.
  18984. 026700          05  FILLER                PIC X VALUE SPACE.
  18985. 026800          05  T-DD-1                  PIC XX.
  18986. 026900     03  FILLER                   PIC X(4) VALUE SPACE.
  18987. 027000     03  ALLOT-NUM-P2             PIC X(4).
  18988. 027100     03  FILLER                   PIC X(6) VALUE SPACE.
  18989. 027200     03  PASTURE-NUM-P2           PIC XX.
  18990. 027300     03  FILLER                   PIC X(8) VALUE SPACE.
  18991. 027400     03  ANML-GRZG-CD-P2          PIC XX.
  18992. 027500     03  FILLER                   PIC X(7) VALUE SPACE.
  18993. 027600     03  ANML-EST-POP-P2          PIC X(5).
  18994. 027700     03  FILLER                   PIC X(6) VALUE SPACE.
  18995. 027800     03  USE-DATE-FROM-1.
  18996. 027900         05  F-MM-2               PIC XX.
  18997. 028000         05  FILLER               PIC X VALUE SPACE.
  18998. 028100         05  F-DD-2               PIC XX.
  18999. 028200     03  FILLER                   PIC X(5) VALUE SPACE.
  19000. 028300     03  USE-DATE-TO-1.
  19001. 028400         05  T-MM-2               PIC XX.
  19002. 028500         05  FILLER               PIC X VALUE SPACE.
  19003. 028600         05  T-DD-2               PIC XX.
  19004. 028700     03  FILLER                   PIC X(5) VALUE SPACE.
  19005. 028800 01  PRINT-4L.
  19006. 028900     03  FILLER                   PIC X(13) VALUE SPACE.
  19007. 029000     03  ASTER-11                 PIC X(4).
  19008. 029100     03  FILLER                   PIC X(6) VALUE SPACE.
  19009. 029200     03  ASTER-12                 PIC X(2).
  19010. 029300     03  FILLER                   PIC X(8) VALUE SPACE.
  19011. 029400     03  ASTER-13                 PIC X(2).
  19012. 029500     03  FILLER                   PIC X(7) VALUE SPACE.
  19013. 029600     03  ASTER-14                 PIC X(5).
  19014. 029700     03  FILLER                   PIC X(6) VALUE SPACE.
  19015. 029800     03  ASTER-15                 PIC X(5).
  19016. 029900     03  FILLER                   PIC X(5) VALUE SPACE.
  19017. 030000     03  ASTER-16                 PIC X(5).
  19018. 030100     03  FILLER                   PIC X(4) VALUE SPACE.
  19019. 030200     03  ASTER-17                 PIC X(4).
  19020. 030300     03  FILLER                   PIC X(6) VALUE SPACE.
  19021. 030400     03  ASTER-18                 PIC X(2).
  19022. 030500     03  FILLER                   PIC X(8) VALUE SPACE.
  19023. 030600     03  ASTER-19                 PIC X(2).
  19024. 030700     03  FILLER                   PIC X(7) VALUE SPACE.
  19025. 030800     03  ASTER-20                 PIC X(5).
  19026. 030900     03  FILLER                   PIC X(6) VALUE SPACE.
  19027. 031000     03  ASTER-21                 PIC X(5).
  19028. 031100     03  FILLER                   PIC X(5) VALUE SPACE.
  19029. 031200     03  ASTER-22                 PIC X(5).
  19030. 031300     03  FILLER                   PIC X(5) VALUE SPACE.
  19031. 031400 01  PRINT-5W.
  19032. 031500     03  FILLER                   PIC X(5) VALUE SPACE.
  19033. 031600     03  LIN-NUM-P3                PIC X(4).
  19034. 031700     03  FILLER                   PIC X(4) VALUE SPACE.
  19035. 031800     03  HERD-NO-P3                PIC X(8).
  19036. 031900     03  FILLER                   PIC X(3) VALUE SPACE.
  19037. 032000     03  ALLOT-NUM-P3              PIC X(4).
  19038. 032100     03  FILLER                   PIC X(5) VALUE SPACE.
  19039. 032200     03  PCT-HERD-P3               PIC X(3).
  19040. 032300     03  FILLER                   PIC X(8) VALUE SPACE.
  19041. 032400     03  ANML-GRZG-CD-P3                PIC XX.
  19042. 032500     03  FILLER                   PIC X(9) VALUE SPACE.
  19043. 032600     03  ANML-EST-POP-P3           PIC X(5).
  19044. 032700     03  FILLER                   PIC X(9) VALUE SPACE.
  19045. 032800     03  USE-DATE-FROM5.
  19046. 032900          05  F-MM-3                PIC XX.
  19047. 033000          05  FILLER              PIC X VALUE SPACE.
  19048. 033100          05  F-DD-3                PIC XX.
  19049. 033200     03  FILLER                   PIC X(5) VALUE SPACE.
  19050. 033300     03  USE-DATE-TO5.
  19051. 033400          05  T-MM-4                PIC XX.
  19052. 033500          05  FILLER              PIC X VALUE SPACE.
  19053. 033600          05  T-DD-4                PIC XX.
  19054. 033700     03  FILLER                   PIC X(4) VALUE SPACE.
  19055. 033800     03  SWA-1P                   PIC X(4).
  19056. 033900     03  FILLER                   PIC X(3) VALUE SPACE.
  19057. 034000     03  SWA-2P                   PIC X(4).
  19058. 034100     03  FILLER                   PIC X(3) VALUE SPACE.
  19059. 034200     03  SWA-3P                   PIC X(4).
  19060. 034300     03  FILLER                   PIC X(3) VALUE SPACE.
  19061. 034400     03  SWA-4P                   PIC X(4).
  19062. 034500     03  FILLER                   PIC X(3) VALUE SPACE.
  19063. 034600     03  SWA-5P                   PIC X(4).
  19064. 034700     03  FILLER                   PIC X(12) VALUE SPACE.
  19065. 034800 01  PRINT-6W.
  19066. 034900     03  FILLER                   PIC X(13) VALUE SPACE.
  19067. 035000     03  ASTER-24                 PIC X(8).
  19068. 035100     03  FILLER                   PIC X(3) VALUE SPACE.
  19069. 035200     03  ASTER-25                 PIC X(4).
  19070. 035300     03  FILLER                   PIC X(5) VALUE SPACE.
  19071. 035400     03  ASTER-26                 PIC X(3).
  19072. 035500     03  FILLER                   PIC X(8) VALUE SPACE.
  19073. 035600     03  ASTER-27                 PIC X(2).
  19074. 035700     03  FILLER                   PIC X(9) VALUE SPACE.
  19075. 035800     03  ASTER-28                 PIC X(5).
  19076. 035900     03  FILLER                   PIC X(9) VALUE SPACE.
  19077. 036000     03  ASTER-29                 PIC X(5).
  19078. 036100     03  FILLER                   PIC X(5) VALUE SPACE.
  19079. 036200     03  ASTER-30                 PIC X(5).
  19080. 036300     03  FILLER                   PIC X(4) VALUE SPACE.
  19081. 036400     03  ASTER-31                 PIC X(4).
  19082. 036500     03  FILLER                   PIC X(3) VALUE SPACE.
  19083. 036600     03  ASTER-32                 PIC X(4).
  19084. 036700     03  FILLER                   PIC X(3) VALUE SPACE.
  19085. 036800     03  ASTER-33                 PIC X(4).
  19086. 036900     03  FILLER                   PIC X(3) VALUE SPACE.
  19087. 037000     03  ASTER-34                 PIC X(4).
  19088. 037100     03  FILLER                   PIC X(3) VALUE SPACE.
  19089. 037200     03  ASTER-35                 PIC X(4).
  19090. 037300     03  FILLER                   PIC X(12) VALUE SPACE.
  19091. 037400 01  INFO-LIN-1.
  19092. 037500     03  FILLER                        PIC X(24) VALUE SPACE.
  19093. 037600     03  FILLER                        PIC X(38) VALUE
  19094. 037700         "IF ERROR CORRECTION IS IN COMMON DATA ".
  19095. 037800     03  FILLER                        PIC X(46) VALUE
  19096. 037900         "(1-12), KEY ALL RECORDS WITH SAME COMMON DATA.".
  19097. 038000     03  FILLER                        PIC X(24) VALUE SPACE.
  19098. 038100 01  INFO-LIN-2.
  19099. 038200     03  FILLER                        PIC X(24) VALUE SPACE.
  19100. 038300     03  FILLER                        PIC X(42) VALUE
  19101. 038400         "IF ERROR CORRECTION IS IN FIELD POSITIONS ".
  19102. 038500     03  FILLER                        PIC X(45) VALUE
  19103. 038600         "(24-73), KEY (1-23) AND RED CORRECTED FIELDS.".
  19104. 038700     03  FILLER                        PIC X(21) VALUE SPACE.
  19105. 038800 01  HERD-GRP-WORK.
  19106. 038900       03  ALLOT-NUM-L                  PIC 9(4).
  19107. 039000       03  ALLOT-NUM-L-A REDEFINES ALLOT-NUM-L  PIC  X(4).
  19108. 039100       03  PASTURE-NUM-L                PIC 9(2).
  19109. 039200       03  PASTURE-NUM-L-A REDEFINES PASTURE-NUM-L  PIC  X(2).
  19110. 039300       03  ANML-GRZG-CD-L               PIC X(2).
  19111. 039400       03  ANML-EST-POP-L               PIC 9(5).
  19112. 039500       03  USE-DATES-L.
  19113. 039600             07  USE-DATES-L-1ST.
  19114. 039700                 09  USE-DATES-L-1ST-MON  PIC 9(2).
  19115. 039800                     88  MON-1-L  VALUES 1 THRU 12.
  19116. 039900                 09  USE-DATES-L-1ST-DAY  PIC 9(2).
  19117. 040000                     88  DAY-1-L  VALUES 1 THRU 31.
  19118. 040100             07  USE-DATES-L-END.
  19119. 040200                 09  USE-DATES-L-END-MON  PIC 9(2).
  19120. 040300                     88  MON-2-L  VALUES 1 THRU 12.
  19121. 040400                 09  USE-DATES-L-END-DAY  PIC 9(2).
  19122. 040500                     88  DAY-2-L  VALUES 1 THRU 31.
  19123. 040600 PROCEDURE DIVISION.
  19124. 040700 005-START SECTION.
  19125. 040800 010-OPEN-FILES.
  19126. 040900     READY DIC-DE.
  19127. 041000     OPEN INPUT VL-VW-IN.
  19128. 041100     OPEN OUTPUT PRINT-FILE, VL-VW-OUT.
  19129. 041200     MOVE SPACE TO PRINT-RCD.
  19130. 041300     WRITE PRINT-RCD BEFORE ADVANCING PAGE.
  19131. 041400     ACCEPT DATE-HOLD FROM DATE.
  19132. 041500     MOVE YEAR-H TO YY.
  19133. 041600     MOVE DAY-H TO DD.
  19134. 041700     MOVE ALPHA-MONTH (MON-H) TO MMM.
  19135. 041800     MOVE PAGE-NO TO PAGE-CNT.
  19136. 041900     MOVE SPACE TO PRINT-2LW, PRINT-4L, PRINT-6W.
  19137. 042000 015-READ.
  19138. 042100     READ VL-VW-IN AT END
  19139. 042200         GO TO 9090-END.
  19140. 042300 020-HOLD.
  19141. 042400     MOVE BLM-ADM-IN TO BLM-ADM-HOLD.
  19142. 042500 025-EDIT-RCD-TYPE.
  19143. 042600     IF RECORD-FORMAT = "VL1D"
  19144. 042700         GO TO 035-EDIT-ST.
  19145. 042800     IF REC-TYP-W = "VL"
  19146. 042900        GO TO 030-EDIT-VL.
  19147. 043000     GO TO 700-EDIT-VW.
  19148. 043100 030-EDIT-VL.
  19149. 043200     MOVE 1 TO HDR-SW1.
  19150. 043300     MOVE ALL "*" TO ASTER-1.
  19151. 043400 035-EDIT-ST.
  19152. 043500     MOVE BLM-ADM-ST-W TO DE-CD-8822-DEC.
  19153. 043600     MOVE 0003 TO DE-NO-8801-DEC.
  19154. 043700     FIND ANY CODE-DEC.
  19155. 043800     MOVE DB-STATUS TO DATA-BASE-STATUS.
  19156. 043900     IF OK
  19157. 044000         GET CODE-DEC
  19158. 044100            MOVE DE-CD-NAM-8823-DEC TO FUNC-HOLD
  19159. 044200            MOVE STATE-NAME TO ST-HDR
  19160. 044300            GO TO 040-EDIT-DT.
  19161. 044400     MOVE 1 TO HDR-SW1.
  19162. 044500     MOVE "UNKNOWN" TO ST-HDR, DIST-HDR.
  19163. 044600     MOVE ALL "*" TO ASTER-2, ASTER-3, ASTER-4, ASTER-5.
  19164. 044700     GO TO 057-EXIT-BLM.
  19165. 044800 040-EDIT-DT.
  19166. 044900     MOVE BLM-ADM-2 TO DE-CD-8822-DEC.
  19167. 045000     MOVE 0003 TO DE-NO-8801-DEC.
  19168. 045100     FIND ANY CODE-DEC.
  19169. 045200     MOVE DB-STATUS TO DATA-BASE-STATUS.
  19170. 045300     IF OK
  19171. 045400         GET CODE-DEC
  19172. 045500         GO TO 045-FIND-DT.
  19173. 045600     MOVE "UNKNOWN" TO DIST-HDR.
  19174. 045700     MOVE 1 TO HDR-SW1.
  19175. 045800     MOVE ALL "*" TO ASTER-3, ASTER-4, ASTER-5.
  19176. 045900     GO TO 057-EXIT-BLM.
  19177. 046000 045-FIND-DT.
  19178. 046100     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  19179. 046200     MOVE DB-STATUS TO DATA-BASE-STATUS.
  19180. 046300     IF OK
  19181. 046400         GET CODE-EXPL-DECE
  19182. 046500         MOVE DE-CD-EXPLN-8827-DECE TO EXPL-HOLD
  19183. 046600         MOVE DIST-NAME TO DIST-HDR
  19184. 046700         GO TO 050-EDIT-RA.
  19185. 046800     MOVE "UNKNOWN" TO DIST-HDR.
  19186. 046900 050-EDIT-RA.
  19187. 047000     MOVE BLM-ADM-3 TO DE-CD-8822-DEC.
  19188. 047100     MOVE 0003 TO DE-NO-8801-DEC.
  19189. 047200     FIND ANY CODE-DEC.
  19190. 047300     MOVE DB-STATUS TO DATA-BASE-STATUS.
  19191. 047400     IF OK
  19192. 047500         GO TO 055-EDIT-PLU.
  19193. 047600     MOVE 1 TO HDR-SW1.
  19194. 047700     MOVE ALL "*" TO ASTER-4, ASTER-5.
  19195. 047800     GO TO 057-EXIT-BLM.
  19196. 047900 055-EDIT-PLU.
  19197. 048000     MOVE BLM-ADM-4 TO DE-CD-8822-DEC.
  19198. 048100     MOVE 0003 TO DE-NO-8801-DEC.
  19199. 048200     FIND ANY CODE-DEC.
  19200. 048300     MOVE DB-STATUS TO DATA-BASE-STATUS.
  19201. 048400     IF OK
  19202. 048500         GO TO 057-EXIT-BLM.
  19203. 048600     MOVE ALL "*" TO ASTER-5.
  19204. 048700     MOVE 1 TO HDR-SW1.
  19205. 048800 057-EXIT-BLM.
  19206. 048900     EXIT.
  19207. 049000 058-MOVE-HERD.
  19208. 049100     MOVE HERD-GRP (1) TO HERD-GRP-WORK.
  19209. 049200     IF ALLOT-NUM-L-A = SPACE GO TO 095-NEXT-SET.
  19210. 049300 060-EDIT-ALLOTMENT.
  19211. 049400     IF ALLOT-NUM-L NUMERIC  GO TO 065-PASTURE.
  19212. 049500     MOVE 1 TO HDR-SW2.
  19213. 049600     PERFORM 081-ASTERISK.
  19214. 049700 065-PASTURE.
  19215. 049800     IF PASTURE-NUM-L-A = SPACE
  19216. 049900         GO TO 070-ANML-SP.
  19217. 050000     IF PASTURE-NUM-L = ZERO
  19218. 050100         GO TO 070-ANML-SP.
  19219. 050200     IF PASTURE-NUM-L NUMERIC AND PASTURE-NUM-L
  19220. 050300         GREATER THAN ZERO
  19221. 050400             GO TO 070-ANML-SP.
  19222. 050500     MOVE 1 TO HDR-SW2.
  19223. 050600     PERFORM 082-ASTERISK.
  19224. 050700 070-ANML-SP.
  19225. 050800*    MOVE ANML-GRZG-CD-L TO DE-CD-8822-DEC.
  19226. 050900*    MOVE 3929 TO DE-NO-8801-DEC.
  19227. 051000*    FIND ANY CODE-DEC.
  19228. 051100*    MOVE DB-STATUS TO DATA-BASE-STATUS.
  19229. 051200*    IF OK
  19230. 051300*        GO TO 075-ANML-EST-POP.
  19231. 051400*    MOVE 1 TO HDR-SW2.
  19232. 051500*    PERFORM 083-ASTERISK.
  19233. 051600 075-ANML-EST-POP.
  19234. 051700     IF ANML-EST-POP-L NUMERIC AND ANML-EST-POP-L > ZERO
  19235. 051800         GO TO 080-USE-DATES.
  19236. 051900     MOVE 1 TO HDR-SW2.
  19237. 052000     PERFORM 084-ASTERISK.
  19238. 052100 080-USE-DATES.
  19239. 052200     IF MON-1-L  NEXT SENTENCE  ELSE
  19240. 052300         MOVE 1 TO HDR-SW2
  19241. 052400     PERFORM 085-ASTERISK.
  19242. 052500     IF DAY-1-L  NEXT SENTENCE  ELSE
  19243. 052600         MOVE 1 TO HDR-SW2
  19244. 052700     PERFORM 085-ASTERISK.
  19245. 052800     IF MON-2-L  NEXT SENTENCE ELSE
  19246. 052900         MOVE 1 TO HDR-SW2
  19247. 053000         PERFORM 086-ASTERISK.
  19248. 053100     IF DAY-2-L  NEXT SENTENCE  ELSE
  19249. 053200         MOVE 1 TO HDR-SW2
  19250. 053300     PERFORM 086-ASTERISK.
  19251. 053400     IF (USE-DATES-L-1ST-MON = 04 OR 06 OR 09 OR 11)
  19252. 053500     AND (USE-DATES-L-1ST-DAY  = 31)
  19253. 053600         MOVE 1 TO HDR-SW2
  19254. 053700         PERFORM 085-ASTERISK.
  19255. 053800     IF (USE-DATES-L-END-MON = 04 OR 06 OR 09 OR 11)
  19256. 053900     AND (USE-DATES-L-END-DAY  = 31)
  19257. 054000         MOVE 1 TO HDR-SW2
  19258. 054100         PERFORM 086-ASTERISK.
  19259. 054200     IF (USE-DATES-L-1ST-MON = 02)
  19260. 054300     AND (USE-DATES-L-1ST-DAY > 28)
  19261. 054400         MOVE 1 TO HDR-SW2
  19262. 054500         PERFORM 085-ASTERISK.
  19263. 054600     IF (USE-DATES-L-END-MON = 02)
  19264. 054700     AND (USE-DATES-L-END-DAY > 28)
  19265. 054800         MOVE 1 TO HDR-SW2
  19266. 054900         PERFORM 086-ASTERISK.
  19267. 055000     GO TO 090-EXIT-EDIT.
  19268. 055100 081-ASTERISK.
  19269. 055200     IF HDR-SW3 = ZERO
  19270. 055300          MOVE ALL "*" TO ASTER-11
  19271. 055400             ELSE MOVE ALL "*" TO ASTER-17.
  19272. 055500 082-ASTERISK.
  19273. 055600     IF HDR-SW3 = ZERO
  19274. 055700         MOVE ALL "*" TO ASTER-12
  19275. 055800             ELSE MOVE ALL "*" TO ASTER-18.
  19276. 055900 083-ASTERISK.
  19277. 056000     IF HDR-SW3 = ZERO
  19278. 056100         MOVE ALL "*" TO ASTER-13
  19279. 056200              ELSE  MOVE ALL "*" TO ASTER-19.
  19280. 056300 084-ASTERISK.
  19281. 056400     IF HDR-SW3 = ZERO
  19282. 056500         MOVE ALL "*" TO ASTER-14
  19283. 056600              ELSE  MOVE ALL "*" TO ASTER-20.
  19284. 056700 085-ASTERISK.
  19285. 056800     IF HDR-SW3 = ZERO
  19286. 056900         MOVE ALL "*" TO ASTER-15
  19287. 057000              ELSE  MOVE ALL "*" TO ASTER-21.
  19288. 057100 086-ASTERISK.
  19289. 057200     IF HDR-SW3 = ZERO
  19290. 057300         MOVE ALL "*" TO ASTER-16
  19291. 057400              ELSE  MOVE ALL "*" TO ASTER-22.
  19292. 057500 090-EXIT-EDIT.
  19293. 057600     EXIT.
  19294. 057700 095-NEXT-SET.
  19295. 057800     MOVE HERD-GRP (2) TO HERD-GRP-WORK.
  19296. 057900     IF ALLOT-NUM-L-A = SPACE
  19297. 058000         GO TO 100-SWITCH-CHECK.
  19298. 058100     MOVE 1 TO HDR-SW3.
  19299. 058200     PERFORM 060-EDIT-ALLOTMENT THRU 090-EXIT-EDIT.
  19300. 058300     MOVE ZERO TO HDR-SW3.
  19301. 058400 100-SWITCH-CHECK.
  19302. 058500     IF HDR-SW1 = ZERO
  19303. 058600         GO TO 115-HDR-SW2.
  19304. 058700     IF PAGE-SW = 1
  19305. 058800          PERFORM 415-HDR-ST-DIST
  19306. 058900          MOVE ZERO TO PAGE-SW.
  19307. 059000     PERFORM 420-HDRS-CNTL.
  19308. 059100 105-WRITE-CONTROL.
  19309. 059200     PERFORM 430-MOVE-CTL-DATA.
  19310. 059300     MOVE PRINT-1LW TO PRINT-RCD.
  19311. 059400     WRITE PRINT-RCD BEFORE 1.
  19312. 059500     MOVE PRINT-2LW TO PRINT-RCD.
  19313. 059600     WRITE PRINT-RCD BEFORE 2.
  19314. 059700     ADD 3 TO LINE-CNT.
  19315. 059800     MOVE 1 TO ERROR-SW.
  19316. 059900 110-WRITE-DATA.
  19317. 060000     PERFORM 425-HDRS-DATA.
  19318. 060100     PERFORM 435-MOVE-DATA THRU 450-EXIT-MOVE.
  19319. 060200     MOVE PRINT-3L TO PRINT-RCD.
  19320. 060300     WRITE PRINT-RCD BEFORE 1.
  19321. 060400     IF HDR-SW2 = ZERO
  19322. 060500         MOVE SPACE TO PRINT-RCD
  19323. 060600         ELSE
  19324. 060700           MOVE PRINT-4L TO PRINT-RCD
  19325. 060800           MOVE 1 TO ERROR-SW.
  19326. 060900     WRITE PRINT-RCD BEFORE 2.
  19327. 061000     ADD 3 TO LINE-CNT.
  19328. 061100 112-DUMMY.
  19329. 061200     GO TO 120-NEW-RCD.
  19330. 061300 115-HDR-SW2.
  19331. 061400     IF HDR-SW2 = ZERO
  19332. 061500         GO TO 120-NEW-RCD.
  19333. 061600     IF PAGE-SW = ZERO
  19334. 061700         PERFORM 110-WRITE-DATA
  19335. 061800         GO TO 120-NEW-RCD.
  19336. 061900     PERFORM 415-HDR-ST-DIST THRU 420-HDRS-CNTL.
  19337. 062000     PERFORM 430-MOVE-CTL-DATA.
  19338. 062100     MOVE PRINT-1LW TO PRINT-RCD.
  19339. 062200     WRITE PRINT-RCD BEFORE 1.
  19340. 062300     ADD 1 TO LINE-CNT.
  19341. 062400     MOVE ZERO TO PAGE-SW.
  19342. 062500     PERFORM 110-WRITE-DATA.
  19343. 062600 120-NEW-RCD.
  19344. 062700     MOVE HERD-GRP (1) TO HERD-GRP-WORK.
  19345. 062800     IF (PASTURE-NUM-L-A = SPACE AND ALLOT-NUM-L-A NOT = SPACE)
  19346. 062900         MOVE ZERO TO PASTURE-NUM-L
  19347. 063000         MOVE HERD-GRP-WORK TO HERD-GRP (1).
  19348. 063100     MOVE HERD-GRP (2) TO HERD-GRP-WORK.
  19349. 063200     IF (PASTURE-NUM-L-A = SPACE AND ALLOT-NUM-L-A NOT = SPACE)
  19350. 063300         MOVE ZERO TO PASTURE-NUM-L
  19351. 063400         MOVE HERD-GRP-WORK TO HERD-GRP (2).
  19352. 063500     IF (ALOT-VL (1) = SPACE) AND
  19353. 063600         (ALOT-VL (2) = SPACE)
  19354. 063700         GO TO 130-READ-NEXT.
  19355. 063800     MOVE VL-RCD TO VL-VW-RCD.
  19356. 063900     WRITE VL-VW-RCD.
  19357. 064000     GO TO 130-READ-NEXT.
  19358. 064100 125-ZERO-OUT.
  19359. 064200     MOVE ZERO TO HDR-SW1, HDR-SW2, HDR-SW3.
  19360. 064300     MOVE SPACE TO PRINT-2LW, PRINT-4L, PRINT-6W.
  19361. 064400 130-READ-NEXT.
  19362. 064500     READ VL-VW-IN AT END
  19363. 064600         GO TO 9090-END.
  19364. 064700     IF RECORD-FORMAT = "VL1D"
  19365. 064800         GO TO 135-ST-CHECK.
  19366. 064900     IF REC-TYP-W = "VL"
  19367. 065000         PERFORM 030-EDIT-VL
  19368. 065100         GO TO 135-ST-CHECK.
  19369. 065200     GO TO 700-EDIT-VW.
  19370. 065300 135-ST-CHECK.
  19371. 065400     IF BLM-ADM-ST-W = ST-HOLD
  19372. 065500         GO TO 150-DIST-CHECK.
  19373. 065600     PERFORM 145-NEW-PAGE.
  19374. 065700     GO TO 035-EDIT-ST.
  19375. 065800 145-NEW-PAGE.
  19376. 065900     MOVE 0 TO PAGE-NO.
  19377. 066000     MOVE 1 TO PAGE-SW.
  19378. 066100     PERFORM 125-ZERO-OUT.
  19379. 066200     PERFORM 020-HOLD.
  19380. 066300 150-DIST-CHECK.
  19381. 066400     IF BLM-ADM-DIST-W = DT-HOLD
  19382. 066500         GO TO 155-RA-CHECK.
  19383. 066600     PERFORM 145-NEW-PAGE.
  19384. 066700     GO TO 035-EDIT-ST.
  19385. 066800 155-RA-CHECK.
  19386. 066900     IF BLM-ADM-RA-W = RA-HOLD
  19387. 067000         GO TO 160-PLU-CHECK.
  19388. 067100     MOVE 1 TO PAGE-SW.
  19389. 067200     PERFORM 125-ZERO-OUT.
  19390. 067300     PERFORM 020-HOLD.
  19391. 067400     GO TO 035-EDIT-ST.
  19392. 067500 160-PLU-CHECK.
  19393. 067600     IF BLM-ADM-PLU-W = PLU-HOLD
  19394. 067700         GO TO 165-EQUAL-CONTROL.
  19395. 067800     MOVE 1 TO PAGE-SW.
  19396. 067900     PERFORM 125-ZERO-OUT.
  19397. 068000     PERFORM 020-HOLD.
  19398. 068100     GO TO 035-EDIT-ST.
  19399. 068200 165-EQUAL-CONTROL.
  19400. 068300     MOVE SPACE TO PRINT-4L.
  19401. 068400     MOVE ZERO TO HDR-SW2.
  19402. 068500     MOVE HERD-GRP (1) TO HERD-GRP-WORK.
  19403. 068600     IF ALLOT-NUM-L-A NOT = SPACE
  19404. 068700         PERFORM 060-EDIT-ALLOTMENT THRU 090-EXIT-EDIT.
  19405. 068800     MOVE HERD-GRP (2) TO HERD-GRP-WORK.
  19406. 068900     MOVE 1 TO HDR-SW3.
  19407. 069000     IF ALLOT-NUM-L-A = SPACE  NEXT SENTENCE  ELSE
  19408. 069100         PERFORM 060-EDIT-ALLOTMENT THRU 090-EXIT-EDIT.
  19409. 069200     MOVE ZERO TO HDR-SW3.
  19410. 069300     IF HDR-SW1 NOT = ZERO
  19411. 069400          GO TO 166-PAGE.
  19412. 069500     IF HDR-SW2 = ZERO
  19413. 069600         GO TO 120-NEW-RCD.
  19414. 069700 166-PAGE.
  19415. 069800     IF PAGE-SW = ZERO
  19416. 069900         GO TO 170-CONTINUE.
  19417. 070000     MOVE ZERO TO PAGE-SW.
  19418. 070100     PERFORM 415-HDR-ST-DIST THRU 420-HDRS-CNTL.
  19419. 070200     PERFORM 430-MOVE-CTL-DATA.
  19420. 070300     MOVE PRINT-1LW TO PRINT-RCD.
  19421. 070400     WRITE PRINT-RCD BEFORE 1.
  19422. 070500     IF HDR-SW1 = 1
  19423. 070600         MOVE PRINT-2LW TO PRINT-RCD
  19424. 070700         MOVE 1 TO ERROR-SW
  19425. 070800          ELSE
  19426. 070900         MOVE SPACE TO PRINT-RCD.
  19427. 071000     WRITE PRINT-RCD BEFORE 2.
  19428. 071100     ADD 3 TO LINE-CNT.
  19429. 071200     PERFORM 425-HDRS-DATA.
  19430. 071300 170-CONTINUE.
  19431. 071400     PERFORM 435-MOVE-DATA THRU 450-EXIT-MOVE.
  19432. 071500     MOVE PRINT-3L TO PRINT-RCD.
  19433. 071600      MOVE 1 TO ERROR-SW.
  19434. 071700     WRITE PRINT-RCD BEFORE 1.
  19435. 071800     IF HDR-SW2 = ZERO
  19436. 071900          MOVE SPACE TO PRINT-RCD
  19437. 072000          ELSE
  19438. 072100          MOVE PRINT-4L TO PRINT-RCD
  19439. 072200          MOVE 1 TO ERROR-SW.
  19440. 072300     WRITE PRINT-RCD BEFORE 2.
  19441. 072400     ADD 3 TO LINE-CNT.
  19442. 072500     IF LINE-CNT GREATER THAN 54
  19443. 072600         MOVE 1 TO PAGE-SW.
  19444. 072700     GO TO 120-NEW-RCD.
  19445. 072800 400-LINE-CNT.
  19446. 072900     MOVE SPACE TO PRINT-RCD.
  19447. 073000     WRITE PRINT-RCD BEFORE PAGE.
  19448. 073100     MOVE ZERO TO LINE-CNT.
  19449. 073200     MOVE 0 TO PAGE-SW.
  19450. 073300     ADD 1 TO PAGE-NO.
  19451. 073400     MOVE PAGE-NO TO PAGE-CNT.
  19452. 073500 415-HDR-ST-DIST.
  19453. 073600     PERFORM 400-LINE-CNT.
  19454. 073700     MOVE HDR-1 TO PRINT-RCD.
  19455. 073800     WRITE PRINT-RCD BEFORE 2.
  19456. 073900     MOVE HDR-2 TO PRINT-RCD.
  19457. 074000     WRITE PRINT-RCD BEFORE 2.
  19458. 074100     MOVE INFO-LIN-1 TO PRINT-RCD.
  19459. 074200     WRITE PRINT-RCD BEFORE 1.
  19460. 074300     MOVE INFO-LIN-2 TO PRINT-RCD.
  19461. 074400     WRITE PRINT-RCD BEFORE 2.
  19462. 074500     ADD 7 TO LINE-CNT.
  19463. 074600 420-HDRS-CNTL.
  19464. 074700     MOVE HDR-3 TO PRINT-RCD.
  19465. 074800     WRITE PRINT-RCD BEFORE 1.
  19466. 074900     MOVE HDR-4 TO PRINT-RCD.
  19467. 075000     WRITE PRINT-RCD BEFORE 1.
  19468. 075100     MOVE HDR-5 TO PRINT-RCD.
  19469. 075200     WRITE PRINT-RCD BEFORE 2.
  19470. 075300     ADD 4 TO LINE-CNT.
  19471. 075400 425-HDRS-DATA.
  19472. 075500     MOVE HDR-6L TO PRINT-RCD.
  19473. 075600     WRITE PRINT-RCD BEFORE 1.
  19474. 075700     MOVE HDR-7L TO PRINT-RCD.
  19475. 075800     WRITE PRINT-RCD BEFORE 1.
  19476. 075900     MOVE HDR-8L TO PRINT-RCD.
  19477. 076000     WRITE PRINT-RCD BEFORE 2.
  19478. 076100     ADD 4 TO LINE-CNT.
  19479. 076200 430-MOVE-CTL-DATA.
  19480. 076300     MOVE RECORD-FORMAT TO REC-TYP-P.
  19481. 076400     MOVE BLM-ADM-ST-W TO BLM-ADM-ST.
  19482. 076500     MOVE BLM-ADM-DIST-W TO BLM-ADM-DIST.
  19483. 076600     MOVE BLM-ADM-RA-W TO BLM-ADM-RA.
  19484. 076700     MOVE BLM-ADM-PLU-W TO BLM-ADM-PLU.
  19485. 076800     MOVE DATA-DATE-W TO DATA-DATE-P.
  19486. 076900     MOVE ACTN-CD-W TO ACTN-CD-P.
  19487. 077000 435-MOVE-DATA.
  19488. 077100     MOVE LIN-NUM-W TO LIN-NUM-P1.
  19489. 077200     MOVE HERD-GRP (1) TO HERD-GRP-WORK.
  19490. 077300     PERFORM 440-MOVE-ALOT-DTD-1.
  19491. 077400     MOVE HERD-GRP (2) TO HERD-GRP-WORK.
  19492. 077500     PERFORM 445-MOVE-ALOT-DTD-2.
  19493. 077600     GO TO 450-EXIT-MOVE.
  19494. 077700 440-MOVE-ALOT-DTD-1.
  19495. 077800     MOVE ALLOT-NUM-L TO ALLOT-NUM-P1.
  19496. 077900     MOVE PASTURE-NUM-L TO PASTURE-NUM-P1.
  19497. 078000     MOVE ANML-GRZG-CD-L TO ANML-GRZG-CD-P1.
  19498. 078100     MOVE ANML-EST-POP-L TO ANML-EST-POP-P1.
  19499. 078200     MOVE USE-DATES-L-1ST-MON TO F-MM-1.
  19500. 078300     MOVE USE-DATES-L-1ST-DAY TO F-DD-1.
  19501. 078400     MOVE USE-DATES-L-END-MON TO T-MM-1.
  19502. 078500     MOVE USE-DATES-L-END-DAY TO T-DD-1.
  19503. 078600 445-MOVE-ALOT-DTD-2.
  19504. 078700     MOVE ALLOT-NUM-L TO ALLOT-NUM-P2.
  19505. 078800     MOVE PASTURE-NUM-L TO PASTURE-NUM-P2.
  19506. 078900     MOVE ANML-GRZG-CD-L TO ANML-GRZG-CD-P2.
  19507. 079000     MOVE ANML-EST-POP-L TO ANML-EST-POP-P2.
  19508. 079100     MOVE USE-DATES-L-1ST-MON TO F-MM-2.
  19509. 079200     MOVE USE-DATES-L-1ST-DAY TO F-DD-2
  19510. 079300     MOVE USE-DATES-L-END-MON TO T-MM-2.
  19511. 079400     MOVE USE-DATES-L-END-DAY TO T-DD-2.
  19512. 079500 450-EXIT-MOVE.
  19513. 079600     EXIT.
  19514. 079700 700-EDIT-VW.
  19515. 079800     PERFORM 145-NEW-PAGE.
  19516. 079900     MOVE "VW" TO VL-VW-TYPE.
  19517. 080000 705-EDIT-FORMAT.
  19518. 080100     IF RECORD-FORMAT = "VW1D"
  19519. 080200         GO TO 710-EXIT-FORMAT.
  19520. 080300     IF REC-TYP-W = "VW"
  19521. 080400         PERFORM 030-EDIT-VL
  19522. 080500         GO TO 710-EXIT-FORMAT.
  19523. 080600     DISPLAY "RECORD NOT PROCESSED***".
  19524. 080700     DISPLAY VL-RCD.
  19525. 080800     READ VL-VW-IN AT END
  19526. 080900         GO TO 9090-END.
  19527. 081000     IF RECORD-FORMAT = "VL1D" OR REC-TYP-W = "VL"
  19528. 081100         DISPLAY "OUT OF SEQUENCE"
  19529. 081200         GO TO 9095-CLOSE.
  19530. 081300 710-EXIT-FORMAT.
  19531. 081400     EXIT.
  19532. 081500 715-BLM-ADM-CHECK.
  19533. 081600     PERFORM 035-EDIT-ST THRU 057-EXIT-BLM.
  19534. 081700 720-ALLOTMENT-W.
  19535. 081800     IF ALLOT-NUM-W NUMERIC  GO TO 725-PCT-HERD.
  19536. 081900     MOVE 1 TO HDR-SW2.
  19537. 082000     MOVE ALL "*" TO ASTER-25.
  19538. 082100 725-PCT-HERD.
  19539. 082200     IF HERD-UNIT-ALLOT-PCT NUMERIC OR
  19540. 082300         HERD-UNIT-ALLOT-PCT = SPACES
  19541. 082400         GO TO 730-ANML-SP.
  19542. 082500     MOVE 1 TO HDR-SW2.
  19543. 082600     MOVE ALL "*" TO ASTER-26.
  19544. 082700 730-ANML-SP.
  19545. 082800*    MOVE ANML-GRZG-CD-W TO DE-CD-8822-DEC.
  19546. 082900*    MOVE 3929 TO DE-NO-8801-DEC.
  19547. 083000*    FIND ANY CODE-DEC.
  19548. 083100*    MOVE DB-STATUS TO DATA-BASE-STATUS.
  19549. 083200*    IF OK
  19550. 083300*        GO TO 735-EST-ANML-POP.
  19551. 083400*    MOVE 1 TO HDR-SW2.
  19552. 083500*    MOVE ALL "*" TO ASTER-27.
  19553. 083600 735-EST-ANML-POP.
  19554. 083700     IF ANML-EST-POP-W NUMERIC OR ANML-EST-POP-W = SPACE
  19555. 083800         GO TO 740-DATES-USE.
  19556. 083900     MOVE 1 TO HDR-SW2.
  19557. 084000     MOVE ALL "*" TO ASTER-28.
  19558. 084100 740-DATES-USE.
  19559. 084200     IF MON-1-W  NEXT SENTENCE  ELSE
  19560. 084300         MOVE 1 TO HDR-SW2
  19561. 084400         MOVE ALL "*" TO ASTER-29.
  19562. 084500     IF DAY-1-W  NEXT SENTENCE  ELSE
  19563. 084600         MOVE 1 TO HDR-SW2
  19564. 084700         MOVE ALL "*" TO ASTER-29.
  19565. 084800     IF MON-2-W  NEXT SENTENCE ELSE
  19566. 084900         MOVE 1 TO HDR-SW2
  19567. 085000         MOVE ALL "*" TO ASTER-30.
  19568. 085100     IF DAY-2-W  NEXT SENTENCE  ELSE
  19569. 085200         MOVE 1 TO HDR-SW2
  19570. 085300         MOVE ALL "*" TO ASTER-30.
  19571. 085400     IF (USE-DATES1ST-MON = 04 OR 06 OR 09 OR 11)
  19572. 085500     AND (USE-DATES1ST-DAY  = 31)
  19573. 085600         MOVE 1 TO HDR-SW2
  19574. 085700         MOVE ALL "*" TO ASTER-29.
  19575. 085800     IF (USE-DATESEND-MON = 04 OR 06 OR 09 OR 11)
  19576. 085900     AND (USE-DATESEND-DAY  = 31)
  19577. 086000         MOVE 1 TO HDR-SW2
  19578. 086100         MOVE ALL "*" TO ASTER-30.
  19579. 086200     IF (USE-DATES1ST-MON = 02)
  19580. 086300     AND (USE-DATES1ST-DAY > 28)
  19581. 086400         MOVE 1 TO HDR-SW2
  19582. 086500         MOVE ALL "*" TO ASTER-29.
  19583. 086600     IF (USE-DATESEND-MON = 02)
  19584. 086700     AND (USE-DATESEND-DAY > 28)
  19585. 086800         MOVE 1 TO HDR-SW2
  19586. 086900         MOVE ALL "*" TO ASTER-30.
  19587. 087000 750-SWA1.
  19588. 087100     IF SWA-GRP = SPACES
  19589. 087200         MOVE ALL "*" TO ASTER-31, ASTER-32,
  19590. 087300         ASTER-33, ASTER-34, ASTER-35
  19591. 087400         MOVE 1 TO HDR-SW2
  19592. 087500         GO TO 775-EDIT-COMPLETE.
  19593. 087600     IF SWA-SET (1) = "9999"
  19594. 087700         GO TO 775-EDIT-COMPLETE.
  19595. 087800     IF SWA-SET (1) = SPACE
  19596. 087900          GO TO 755-SWA2.
  19597. 088000     IF SWACD-W (1) = SPACES
  19598. 088100         MOVE ALL "*" TO ASTER-31
  19599. 088200         MOVE 1 TO HDR-SW2
  19600. 088300         GO TO 755-SWA2.
  19601. 088400     IF SWACD-W (1) NOT ALPHABETIC
  19602. 088500         MOVE ALL "*" TO ASTER-31
  19603. 088600         MOVE 1 TO HDR-SW2
  19604. 088700         GO TO 755-SWA2.
  19605. 088800     IF SWA-THREE (1) NUMERIC
  19606. 088900         GO TO 755-SWA2.
  19607. 089000     MOVE ALL "*" TO ASTER-31.
  19608. 089100     MOVE 1 TO HDR-SW2.
  19609. 089200 755-SWA2.
  19610. 089300     IF SWA-SET (2) = SPACE
  19611. 089400          GO TO 760-SWA3.
  19612. 089500     IF SWACD-W (2) = SPACES
  19613. 089600         MOVE ALL "*" TO ASTER-32
  19614. 089700         MOVE 1 TO HDR-SW2
  19615. 089800         GO TO 760-SWA3.
  19616. 089900     IF SWACD-W (2) NOT ALPHABETIC
  19617. 090000         MOVE ALL "*" TO ASTER-32
  19618. 090100         MOVE 1 TO HDR-SW2
  19619. 090200         GO TO 760-SWA3.
  19620. 090300     IF SWA-THREE (2) NUMERIC
  19621. 090400         GO TO 760-SWA3.
  19622. 090500     MOVE ALL "*" TO ASTER-32.
  19623. 090600     MOVE 1 TO HDR-SW2.
  19624. 090700 760-SWA3.
  19625. 090800     IF SWA-SET (3) = SPACE
  19626. 090900          GO TO 765-SWA4.
  19627. 091000     IF SWACD-W (3) = SPACES
  19628. 091100         MOVE ALL "*" TO ASTER-33
  19629. 091200         MOVE 1 TO HDR-SW2
  19630. 091300         GO TO 765-SWA4.
  19631. 091400     IF SWACD-W (3) NOT ALPHABETIC
  19632. 091500         MOVE ALL "*" TO ASTER-33
  19633. 091600         MOVE 1 TO HDR-SW2
  19634. 091700         GO TO 765-SWA4.
  19635. 091800     IF SWA-THREE (3) NUMERIC
  19636. 091900         GO TO 765-SWA4.
  19637. 092000     MOVE ALL "*" TO ASTER-33.
  19638. 092100     MOVE 1 TO HDR-SW2.
  19639. 092200 765-SWA4.
  19640. 092300     IF SWA-SET (4) = SPACE
  19641. 092400          GO TO 770-SWA5.
  19642. 092500     IF SWACD-W (4) = SPACES
  19643. 092600         MOVE ALL "*" TO ASTER-34
  19644. 092700         MOVE 1 TO HDR-SW2
  19645. 092800         GO TO 770-SWA5.
  19646. 092900     IF SWACD-W (4) NOT ALPHABETIC
  19647. 093000         MOVE ALL "*" TO ASTER-34
  19648. 093100         MOVE 1 TO HDR-SW2
  19649. 093200         GO TO 770-SWA5.
  19650. 093300     IF SWA-THREE (4) NUMERIC
  19651. 093400         GO TO 770-SWA5.
  19652. 093500     MOVE ALL "*" TO ASTER-34.
  19653. 093600     MOVE 1 TO HDR-SW2.
  19654. 093700 770-SWA5.
  19655. 093800     IF SWA-SET (5) = SPACE
  19656. 093900          GO TO 775-EDIT-COMPLETE.
  19657. 094000     IF SWACD-W (5) = SPACES
  19658. 094100         MOVE ALL "*" TO ASTER-35
  19659. 094200         MOVE 1 TO HDR-SW2
  19660. 094300         GO TO 775-EDIT-COMPLETE.
  19661. 094400     IF SWACD-W (5) NOT ALPHABETIC
  19662. 094500         MOVE ALL "*" TO ASTER-35
  19663. 094600         MOVE 1 TO HDR-SW2
  19664. 094700         GO TO 775-EDIT-COMPLETE.
  19665. 094800     IF SWA-THREE (5) NUMERIC
  19666. 094900         GO TO 775-EDIT-COMPLETE.
  19667. 095000     MOVE ALL "*" TO ASTER-35.
  19668. 095100     MOVE 1 TO HDR-SW2.
  19669. 095200 775-EDIT-COMPLETE.
  19670. 095300     EXIT.
  19671. 095400 776-HDR-CHECK.
  19672. 095500     IF HDR-SW1 = ZERO
  19673. 095600         GO TO 795-HDR-SW2.
  19674. 095700     IF PAGE-SW = 1
  19675. 095800         PERFORM 415-HDR-ST-DIST
  19676. 095900         MOVE ZERO TO PAGE-SW.
  19677. 096000     PERFORM 420-HDRS-CNTL.
  19678. 096100 780-WRITE-CNTL.
  19679. 096200     PERFORM 430-MOVE-CTL-DATA.
  19680. 096300     MOVE PRINT-1LW TO PRINT-RCD.
  19681. 096400     WRITE PRINT-RCD BEFORE 1.
  19682. 096500     MOVE PRINT-2LW TO PRINT-RCD.
  19683. 096600     WRITE PRINT-RCD BEFORE 2.
  19684. 096700     ADD 3 TO LINE-CNT.
  19685. 096800     MOVE 1 TO ERROR-SW.
  19686. 096900 785-WRITE-DATA.
  19687. 097000     PERFORM 900-HDRS-W THRU 910-DATA-W.
  19688. 097100     MOVE PRINT-5W TO PRINT-RCD.
  19689. 097200     WRITE PRINT-RCD BEFORE 1.
  19690. 097300     IF HDR-SW2 = 1
  19691. 097400         MOVE PRINT-6W TO PRINT-RCD
  19692. 097500         MOVE 1 TO ERROR-SW
  19693. 097600     ELSE
  19694. 097700         MOVE SPACE TO PRINT-RCD.
  19695. 097800     WRITE PRINT-RCD BEFORE 2.
  19696. 097900     ADD 3 TO LINE-CNT.
  19697. 098000 790-DUMMY.
  19698. 098100     GO TO 800-NEW-RCD.
  19699. 098200 795-HDR-SW2.
  19700. 098300     IF HDR-SW2 = ZERO
  19701. 098400         GO TO 800-NEW-RCD.
  19702. 098500     IF PAGE-SW = ZERO
  19703. 098600         PERFORM 785-WRITE-DATA
  19704. 098700         GO TO 800-NEW-RCD.
  19705. 098800     PERFORM 415-HDR-ST-DIST THRU 420-HDRS-CNTL.
  19706. 098900     MOVE ZERO TO PAGE-SW.
  19707. 099000     PERFORM 780-WRITE-CNTL THRU 785-WRITE-DATA.
  19708. 099100 800-NEW-RCD.
  19709. 099200     IF HERD-UNIT-ALLOT-PCT = SPACE
  19710. 099300         MOVE ZERO TO HERD-UNIT-ALLOT-PCT.
  19711. 099400     IF ANML-EST-POP-W = SPACE
  19712. 099500         MOVE ZERO TO ANML-EST-POP-W.
  19713. 099600     MOVE VW-RCD TO VL-VW-RCD.
  19714. 099700     WRITE VL-VW-RCD.
  19715. 099800     GO TO 810-READ-NEXT.
  19716. 099900 805-ZERO-OUT.
  19717. 100000     MOVE ZERO TO HDR-SW1, HDR-SW2
  19718. 100100     MOVE SPACE TO PRINT-2LW, PRINT-6W.
  19719. 100200 810-READ-NEXT.
  19720. 100300     READ VL-VW-IN AT END
  19721. 100400         GO TO 9090-END.
  19722. 100500     PERFORM 705-EDIT-FORMAT THRU 710-EXIT-FORMAT.
  19723. 100600 815-BLM-ST.
  19724. 100700     IF BLM-ADM-ST-W = ST-HOLD
  19725. 100800         GO TO 820-BLM-DIST.
  19726. 100900     PERFORM 145-NEW-PAGE.
  19727. 101000     GO TO 715-BLM-ADM-CHECK.
  19728. 101100 820-BLM-DIST.
  19729. 101200     IF BLM-ADM-DIST-W = DT-HOLD
  19730. 101300          GO TO 825-BLM-RA.
  19731. 101400     PERFORM 145-NEW-PAGE.
  19732. 101500     GO TO 715-BLM-ADM-CHECK.
  19733. 101600 825-BLM-RA.
  19734. 101700     IF BLM-ADM-RA-W = RA-HOLD
  19735. 101800          GO TO 830-BLM-PLU.
  19736. 101900     MOVE 1 TO PAGE-SW.
  19737. 102000     PERFORM 125-ZERO-OUT.
  19738. 102100     PERFORM 020-HOLD.
  19739. 102200     GO TO 715-BLM-ADM-CHECK.
  19740. 102300 830-BLM-PLU.
  19741. 102400     IF BLM-ADM-PLU-W = PLU-HOLD
  19742. 102500         GO TO 840-EDIT-NEXT.
  19743. 102600     MOVE 1 TO PAGE-SW.
  19744. 102700     PERFORM 125-ZERO-OUT.
  19745. 102800     PERFORM 020-HOLD.
  19746. 102900     GO TO 715-BLM-ADM-CHECK.
  19747. 103000 840-EDIT-NEXT.
  19748. 103100     MOVE SPACE TO PRINT-6W.
  19749. 103200     MOVE ZERO TO HDR-SW2.
  19750. 103300     PERFORM 720-ALLOTMENT-W THRU 775-EDIT-COMPLETE.
  19751. 103400     IF HDR-SW1 NOT = TO ZERO
  19752. 103500          GO TO 841-PAGE.
  19753. 103600     IF HDR-SW2 = ZERO
  19754. 103700         GO TO 800-NEW-RCD.
  19755. 103800 841-PAGE.
  19756. 103900     IF PAGE-SW = ZERO
  19757. 104000         GO TO 850-CONTINUE.
  19758. 104100     MOVE ZERO TO PAGE-SW.
  19759. 104200     PERFORM 415-HDR-ST-DIST THRU 420-HDRS-CNTL.
  19760. 104300     PERFORM 430-MOVE-CTL-DATA.
  19761. 104400     MOVE PRINT-1LW TO PRINT-RCD.
  19762. 104500     WRITE PRINT-RCD BEFORE 1.
  19763. 104600     IF HDR-SW1 = ZERO
  19764. 104700         MOVE SPACE TO PRINT-RCD
  19765. 104800     ELSE
  19766. 104900         MOVE PRINT-2LW TO PRINT-RCD
  19767. 105000         MOVE 1 TO ERROR-SW.
  19768. 105100     WRITE PRINT-RCD BEFORE 2.
  19769. 105200     ADD 3 TO LINE-CNT.
  19770. 105300     PERFORM 900-HDRS-W.
  19771. 105400 850-CONTINUE.
  19772. 105500     PERFORM 910-DATA-W.
  19773. 105600     MOVE PRINT-5W TO PRINT-RCD.
  19774. 105700     WRITE PRINT-RCD BEFORE 1.
  19775. 105800     IF HDR-SW2 = ZERO
  19776. 105900          MOVE SPACE TO PRINT-RCD
  19777. 106000          ELSE
  19778. 106100          MOVE PRINT-6W TO PRINT-RCD
  19779. 106200          MOVE 1 TO ERROR-SW.
  19780. 106300     WRITE PRINT-RCD BEFORE 2.
  19781. 106400     ADD 3 TO LINE-CNT.
  19782. 106500     IF LINE-CNT > 54
  19783. 106600        MOVE 1 TO PAGE-SW.
  19784. 106700     GO TO 800-NEW-RCD.
  19785. 106800 900-HDRS-W.
  19786. 106900     MOVE HDR-9W TO PRINT-RCD.
  19787. 107000     WRITE PRINT-RCD BEFORE 1.
  19788. 107100     MOVE HDR-10W TO PRINT-RCD.
  19789. 107200     WRITE PRINT-RCD BEFORE 1.
  19790. 107300     MOVE HDR-11W TO PRINT-RCD.
  19791. 107400     WRITE PRINT-RCD BEFORE 2.
  19792. 107500     ADD 4 TO LINE-CNT.
  19793. 107600 910-DATA-W.
  19794. 107700     MOVE LIN-NUM-W TO LIN-NUM-P3.
  19795. 107800     MOVE HERD-UNIT-NUM-W TO HERD-NO-P3.
  19796. 107900     MOVE ALLOT-NUM-W TO ALLOT-NUM-P3.
  19797. 108000     MOVE HERD-UNIT-ALLOT-PCT TO PCT-HERD-P3.
  19798. 108100     MOVE ANML-GRZG-CD-W TO ANML-GRZG-CD-P3.
  19799. 108200     MOVE ANML-EST-POP-W TO ANML-EST-POP-P3.
  19800. 108300     MOVE USE-DATES1ST-MON TO F-MM-3.
  19801. 108400     MOVE USE-DATES1ST-DAY TO F-DD-3.
  19802. 108500     MOVE USE-DATESEND-MON TO T-MM-4.
  19803. 108600     MOVE USE-DATESEND-DAY TO T-DD-4.
  19804. 108700     MOVE SWA-SET (1) TO SWA-1P.
  19805. 108800     MOVE SWA-SET (2) TO SWA-2P.
  19806. 108900     MOVE SWA-SET (3) TO SWA-3P.
  19807. 109000     MOVE SWA-SET (4) TO SWA-4P.
  19808. 109100     MOVE SWA-SET (5) TO SWA-5P.
  19809. 109200 9090-END.
  19810. 109300     IF ERROR-SW = 1
  19811. 109400          PERFORM 400-LINE-CNT
  19812. 109500          GO TO 9095-CLOSE.
  19813. 109600     DISPLAY "NO ERRORS DETECTED ON THESE RECORDS".
  19814. 109700 9095-CLOSE.
  19815. 109800     CLOSE VL-VW-IN, VL-VW-OUT, PRINT-FILE.
  19816. 109900     FINISH.
  19817. 110000     STOP RUN.
  19818. 000000*-----------------------------------------------------------------
  19819. 000100 IDENTIFICATION DIVISION.
  19820. 000200 PROGRAM-ID. ES510P.
  19821. 000300*        ALLOTMENT LEVEL ACREAGE (P1 LIST)
  19822. 000400*
  19823. 000500 AUTHOR. M.QUANDT.
  19824. 000600 ENVIRONMENT DIVISION.
  19825. 000700 CONFIGURATION SECTION.
  19826. 000800 SOURCE-COMPUTER. LEVEL-66-ASCII.
  19827. 000900 OBJECT-COMPUTER. LEVEL-66-ASCII.
  19828. 001000 INPUT-OUTPUT SECTION.
  19829. 001100 FILE-CONTROL.
  19830. 001200     SELECT INPUT-FILE ASSIGN TO I1
  19831. 001300         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  19832. 001400     SELECT PRINT-OUT ASSIGN TO P1
  19833. 001500         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  19834. 001600 DATA DIVISION.
  19835. 001700 SUB-SCHEMA SECTION.
  19836. 001800 DB  CODVAL2 WITHIN BLMDIC.
  19837. 001900 FILE SECTION.
  19838. 002000 FD  INPUT-FILE
  19839. 002100     CODE-SET IS GBCD
  19840. 002200     LABEL RECORDS ARE STANDARD.
  19841. 002300 01  IN-RECORD.
  19842. 002400     05  REC-TYP                           PIC XX.
  19843. 002500     05  FMT-NUM                           PIC X.
  19844. 002600     05  FORMAT-CD                         PIC X.
  19845. 002700     05  BLM-ADM-U                         PIC X(8).
  19846. 002800     05  ALLOT-NUM                         PIC X(4).
  19847. 002900     05  PASTURE-NUM                       PIC XX.
  19848. 003000     05  DATA-DATE                         PIC X(6).
  19849. 003100     05  ACTION-CD                         PIC X.
  19850. 003200     05  MAP-SRC                           PIC X(4).
  19851. 003300     05  IN-MTR-MER-CD                     PIC XX.
  19852. 003400     05  LIN-NUM                           PIC X(4).
  19853. 003500     05  MTR-TWSHP                         PIC X(5).
  19854. 003600     05  IN-MTR-RNG                        PIC X(5).
  19855. 003700     05  IN-SEC-SECT                       PIC XXX.
  19856. 003800     05  SWA                               PIC X(4).
  19857. 003900     05  FILLER                            PIC X(16).
  19858. 004000     05  ACR-DU                            PIC 9(5).
  19859. 004100     05  COMBO.
  19860. 004200         10  OWN-TYP                       PIC X(4).
  19861. 004300         10  JURIS                         PIC X(4).
  19862. 004400         10  IN-ADMIN                      PIC X(4).
  19863. 004500         10  LAND-TYP                      PIC X(4).
  19864. 004600     05  FILLER                            PIC X.
  19865. 004700 FD  PRINT-OUT
  19866. 004800     CODE-SET IS GBCD
  19867. 004900     LABEL RECORDS ARE STANDARD.
  19868. 005000 01  PRINT-LINE                            PIC X(132).
  19869. 005100 WORKING-STORAGE SECTION.
  19870. 005200 77  NEW-ALLOT                             PIC X(4).
  19871. 005300 77  SUB-CHK  PIC 9(4)  VALUE ZERO.
  19872. 005400 77  OLD-ALLOT                             PIC X(4).
  19873. 005500 77  NEW-PASTURE                           PIC XX.
  19874. 005600 77  OLD-PASTURE                           PIC XX.
  19875. 005700 77  NEW-SWA                               PIC X(4).
  19876. 005800 77  OLD-SWA                               PIC X(4).
  19877. 005900 77  NEW-SKEY                              PIC X(8).
  19878. 006000 77  OLD-SKEY                              PIC X(8).
  19879. 006100 77  PAGE-COUNT        PIC 9(5) VALUE ZERO.
  19880. 006200 77  LINE-COUNT                            PIC 99 VALUE ZERO.
  19881. 006300 77  READ-COUNT  PIC 9(7)  VALUE ZEROS.
  19882. 006400 77  DATA-PRINT-COUNT  PIC 9(7)  VALUE ZEROS.
  19883. 006500 77  WORK-SPACES  PIC X(132) VALUE SPACES.
  19884. 006600 77  WORK-PRINT                            PIC X(132).
  19885. 006700 77  TOTAL-SWA-ACRES  PIC 9(7) VALUE ZERO.
  19886. 006800 77  TOTAL-PASTURE-ACRES  PIC 9(7) VALUE ZERO.
  19887. 006900 77  TOTAL-ALLOT-ACRES  PIC 9(7) VALUE ZERO.
  19888. 007000 77  SUB-SCRIPT          PIC 9999 VALUE ZERO.
  19889. 007100 77  FIND-SCRIPT  PIC 9999 VALUE ZERO.
  19890. 007200 77  SAVE-PASTURE                          PIC XX.
  19891. 007300 77  WS-PASTURE                            PIC XX.
  19892. 007400 77  SAVE-ALLOTMENT                        PIC 9(4).
  19893. 007500 01  HOLD-AREA.
  19894. 007600     03  ADST-DIST-RA-PLU-CDS-H.
  19895. 007700         05  ADST-CD-H  PIC XX.
  19896. 007800         05  DIST-CD-H  PIC XX.
  19897. 007900         05  RA-CD-H  PIC XX.
  19898. 008000         05  PLU-CD-H  PIC XX.
  19899. 008100     03  DE-CD-EXPLN-8827-DECE-H.
  19900. 008200         05  DIST-NAM-H  PIC X(12).
  19901. 008300         05  RA-NAM-H  PIC X(13).
  19902. 008400         05  PLU-NAM-H  PIC X(15).
  19903. 008500     03  DE-CD-NAM-8823-DEC-H.
  19904. 008600         05  ST-NAM-H  PIC X(10).
  19905. 008700         05  FILLER  PIC X(14).
  19906. 008800 01  PAG-HDR-1.
  19907. 008900     03  FILLER        PIC X(13) VALUE "REPORT DATE: ".
  19908. 009000     03  HEADER-DATE.
  19909. 009100         05  MO-HDR    PIC 99.
  19910. 009200         05  FILLER    PIC X     VALUE "/".
  19911. 009300         05  DA-HDR    PIC 99.
  19912. 009400         05  FILLER    PIC X     VALUE "/".
  19913. 009500         05  YR-HDR    PIC 99.
  19914. 009600     03  FILLER        PIC X(28) VALUE SPACES.
  19915. 009700     03  FILLER        PIC X(23) VALUE "U.S.D.I. BUREAU OF LAND".
  19916. 009800     03  FILLER        PIC X(11) VALUE " MANAGEMENT".
  19917. 009900     03  FILLER        PIC X(22) VALUE SPACES.
  19918. 010000     03  FILLER        PIC X(15) VALUE "PCN: P010      ".
  19919. 010100     03  FILLER        PIC X(6) VALUE " PAGE ".
  19920. 010200     03  PAGE-NO       PIC ZZ,ZZ9.
  19921. 010300 01  PAG-HDR-3.
  19922. 010400     03  FILLER        PIC X(20) VALUE "    STATE           ".
  19923. 010500     03  STATE-NAME    PIC X(10).
  19924. 010600     03  FILLER        PIC X(24) VALUE SPACES.
  19925. 010700     03  FILLER        PIC X(21) VALUE "ECOLOGICAL SITE INVEN".
  19926. 010800     03  FILLER        PIC X(04) VALUE "TORY".
  19927. 010900     03  FILLER        PIC X(53) VALUE SPACES.
  19928. 011000 01  PAG-HDR-4.
  19929. 011100     03  FILLER        PIC X(20) VALUE "    DISTRICT        ".
  19930. 011200     03  DIST-NAME     PIC X(12).
  19931. 011300     03  FILLER        PIC X(100) VALUE SPACES.
  19932. 011400 01  PAG-HDR-5.
  19933. 011500     03  FILLER        PIC X(20) VALUE "    RESOURCE AREA   ".
  19934. 011600     03  RA-NAME       PIC X(13).
  19935. 011700     03  FILLER        PIC X(16) VALUE SPACES.
  19936. 011800     03  FILLER        PIC X(21) VALUE "ALLOTMENT LEVEL ACREA".
  19937. 011900     03  FILLER        PIC X(14) VALUE "GE INFORMATION".
  19938. 012000     03  FILLER        PIC X(48) VALUE SPACES.
  19939. 012100 01  PAG-HDR-6.
  19940. 012200     03  FILLER        PIC X(20) VALUE "    PLANNING UNIT   ".
  19941. 012300     03  PU-NAME      PIC X(15).
  19942. 012400     03  FILLER        PIC X(97) VALUE SPACES.
  19943. 012500 01  COL-HDR-1.
  19944. 012600     03  FILLER        PIC X(59) VALUE SPACES.
  19945. 012700     03  FILLER        PIC X(10) VALUE "TYPE  MAP ".
  19946. 012800     03  FILLER        PIC X(63) VALUE SPACES.
  19947. 012900 01  COL-HDR-2.
  19948. 013000     03  FILLER        PIC X(21) VALUE "    ALLOTMENT  PASTUR".
  19949. 013100     03  FILLER        PIC X(21) VALUE "E  SWA    ACRES  OWNE".
  19950. 013200     03  FILLER        PIC X(21) VALUE "R  JURIS  ADMIN  LAND".
  19951. 013300     03  FILLER        PIC X(21) VALUE "  SOURCE  MERID  TOWN".
  19952. 013400     03  FILLER        PIC X(21) VALUE "SHIP  RANGE  SEC  ALI".
  19953. 013500     03  FILLER        PIC X(21) VALUE "QUOT PARTS           ".
  19954. 013600     03  FILLER        PIC X(6)  VALUE SPACES.
  19955. 013700 01  DATA-LINE-1.
  19956. 013800     03  FILLER        PIC X(6).
  19957. 013900     03  ALLOT-NO-P    PIC 9999.
  19958. 014000     03  FILLER        PIC X(7).
  19959. 014100     03  PASTURE-P     PIC XX.
  19960. 014200     03  FILLER        PIC X(4).
  19961. 014300     03  SWA-P         PIC X(4).
  19962. 014400     03  FILLER        PIC XX.
  19963. 014500     03  ACRES-P       PIC Z(6)9.
  19964. 014600     03  FILLER        PIC XX.
  19965. 014700     03  OWNER-P       PIC X(4).
  19966. 014800     03  FILLER        PIC XXX.
  19967. 014900     03  JURIS-P       PIC X(4).
  19968. 015000     03  FILLER        PIC XXX.
  19969. 015100     03  ADMIN-P       PIC X(4).
  19970. 015200     03  FILLER        PIC XXX.
  19971. 015300     03  LAND-TYPE-P   PIC X(4).
  19972. 015400     03  FILLER        PIC XXX.
  19973. 015500     03  MAP-SPCE-P    PIC X(4).
  19974. 015600     03  FILLER        PIC X(4).
  19975. 015700     03  MERID-P       PIC Z9.
  19976. 015800     03  FILLER        PIC X(5).
  19977. 015900     03  TWNSHP-P      PIC X(5).
  19978. 016000     03  FILLER        PIC X(4).
  19979. 016100     03  RNGE-P        PIC X(5).
  19980. 016200     03  FILLER        PIC XX.
  19981. 016300     03  SECT-P        PIC XXX.
  19982. 016400     03  FILLER        PIC XX.
  19983. 016500     03  ALIQ-PTS-P    PIC X(19).
  19984. 016600     03  FILLER        PIC X(11).
  19985. 016700 01  DATA-LINE-2 REDEFINES DATA-LINE-1 PIC X(132).
  19986. 016800 01  SWA-TOTAL-LINE.
  19987. 016900     03  FILLER        PIC X(6)  VALUE SPACES.
  19988. 017000     03  ALLT-P        PIC 9(4).
  19989. 017100     03  FILLER        PIC X(7)  VALUE SPACES.
  19990. 017200     03  PASTR-P       PIC XX.
  19991. 017300     03  FILLER        PIC XXX   VALUE SPACES.
  19992. 017400     03  TOTALL-P      PIC X(5)  VALUE "TOTAL".
  19993. 017500     03  FILLER        PIC XX    VALUE SPACES.
  19994. 017600     03  TOTL-ACRS     PIC Z(6)9.
  19995. 017700     03  FILLER        PIC X(96) VALUE SPACES.
  19996. 017800 01  PASTURE-TOTAL-LINE.
  19997. 017900     03  FILLER        PIC X(6)  VALUE SPACES.
  19998. 018000     03  ALLOT-P       PIC 9(4).
  19999. 018100     03  FILLER        PIC X(5)  VALUE SPACES.
  20000. 018200     03  PAS-TOT-P     PIC X(5)  VALUE "TOTAL".
  20001. 018300     03  FILLER        PIC X(9)  VALUE SPACES.
  20002. 018400     03  ACRS-P        PIC Z(6)9.
  20003.  
  20004. 018500     03  FILLER        PIC X(96) VALUE SPACES.
  20005. 018600 01  ALLOTMENT-TOTAL-LINE.
  20006. 018700     03  FILLER        PIC X(6)  VALUE SPACES.
  20007. 018800     03  ALLOT-TOT-P   PIC X(5)  VALUE "TOTAL".
  20008. 018900     03  FILLER        PIC X(18) VALUE SPACES.
  20009. 019000     03  ACRES-P       PIC Z(6)9.
  20010. 019100     03  FILLER        PIC X(96) VALUE SPACES.
  20011. 019200 01  OWNER-SUMMARY-LINE-1.
  20012. 019300     03  FILLER        PIC X(17) VALUE "OWNERSHIP SUMMARY".
  20013. 019400     03  FILLER        PIC X(12) VALUE SPACES.
  20014. 019500     03  ACRE-SUM-P    PIC Z(6)9.
  20015. 019600     03  FILLER        PIC XX    VALUE SPACES.
  20016. 019700     03  OWNR-SUM-P    PIC X(4).
  20017. 019800     03  FILLER        PIC XXX   VALUE SPACES.
  20018. 019900     03  JURIS-SUM-P   PIC X(4).
  20019. 020000     03  FILLER        PIC XXX     VALUE SPACES.
  20020. 020100     03  ADMIN-SUM-P   PIC X(4).
  20021. 020200     03  FILLER        PIC XXX     VALUE SPACES.
  20022. 020300     03  LND-TYP-SUM-P PIC X(4).
  20023. 020400     03  FILLER        PIC X(69) VALUE SPACES.
  20024. 020500 01  OWNER-SUMMARY-LINE-2.
  20025. 020600     03  FILLER        PIC X(14) VALUE " FOR ALLOTMENT".
  20026. 020700     03  FILLER        PIC X(15) VALUE SPACES.
  20027. 020800     03  ACRE-SUM-2    PIC Z(6)9.
  20028. 020900     03  FILLER        PIC XX    VALUE SPACES.
  20029. 021000     03  OWNR-SUM-2    PIC X(4).
  20030. 021100     03  FILLER        PIC XXX   VALUE SPACES.
  20031. 021200     03  JURIS-SUM-2   PIC X(4).
  20032. 021300     03  FILLER        PIC X     VALUE SPACES.
  20033. 021400     03  ADMIN-SUM-2   PIC X(8).
  20034. 021500     03  FILLER        PIC X     VALUE SPACES.
  20035. 021600     03  LND-TYP-SUM-2 PIC X(4).
  20036. 021700     03  FILLER        PIC X(69) VALUE SPACES.
  20037. 021800 01  OWNER-SUMMARY-LINE-3.
  20038. 021900     03  FILLER        PIC X(29) VALUE SPACES.
  20039. 022000     03  ACRE-SUM-3    PIC Z(6)9.
  20040. 022100     03  FILLER        PIC XX    VALUE SPACES.
  20041. 022200     03  OWNR-SUM-3    PIC X(4).
  20042. 022300     03  FILLER        PIC XXX   VALUE SPACES.
  20043. 022400     03  JURIS-SUM-3   PIC X(4).
  20044. 022500     03  FILLER        PIC X     VALUE SPACES.
  20045. 022600     03  ADMIN-SUM-3   PIC X(8).
  20046. 022700     03  FILLER        PIC X     VALUE SPACES.
  20047. 022800     03  LND-TYP-SUM-3 PIC X(4).
  20048. 022900     03  FILLER        PIC X(69) VALUE SPACES.
  20049. 023000 01  DATE-TODAY.
  20050. 023100     05  THIS-YEAR                         PIC 99.
  20051. 023200     05  THIS-MONTH                        PIC 99.
  20052. 023300     05  THIS-DAY                          PIC 99.
  20053. 023400 01  EOF-CONDITION                         PIC 9.
  20054. 023500     88  FILE-END  VALUE IS 1.
  20055. 023600 01  FIRST-DATA-CONDITION                  PIC 9.
  20056. 023700     88  FIRST-DATA-LINE  VALUE IS 1.
  20057. 023800 01  COMBO-TABLE.
  20058. 023900     05  TABLE-ELEMENT OCCURS 200 TIMES.
  20059. 024000         10  COMBO-ELEMENT.
  20060. 024100             15  OWNER-ELEMENT  PIC X(4).
  20061. 024200             15  JURIS-ELEMENT  PIC X(4).
  20062. 024300             15  ADMIN-ELEMENT  PIC X(4).
  20063. 024400             15  LAND-TYPE-ELEMENT  PIC X(4).
  20064. 024500         10  TOTAL-ELEMENT  PIC 9(7).
  20065. 024600 01  OWNER-LINE2-SPACES.
  20066. 024700     05  FILLER  PIC X(14) VALUE " FOR ALLOTMENT".
  20067. 024800     05  FILLER  PIC X(118) VALUE SPACES.
  20068. 024900 PROCEDURE DIVISION.
  20069. 025000 10-HOUSEKEEPING.
  20070. 025100     PERFORM 200-HOUSEKEEP.
  20071. 025200 20-READ-PROCESS.
  20072. 025300     PERFORM 210-READ-INPUT.
  20073. 025400     IF FILE-END
  20074. 025500         PERFORM 900-WRAPUP
  20075. 025600         STOP RUN.
  20076. 025700     IF PASTURE-NUM EQUAL "00"
  20077. 025800         MOVE SPACES TO WS-PASTURE
  20078. 025900     ELSE MOVE PASTURE-NUM TO WS-PASTURE.
  20079. 026000     PERFORM 225-SKEY-CHANGE.
  20080. 026100     PERFORM 230-ALLOT-CHANGE.
  20081. 026200     PERFORM 240-PASTURE-CHANGE.
  20082. 026300     PERFORM 250-SWA-CHANGE.
  20083. 026400     IF NEW-ALLOT NOT EQUAL OLD-ALLOT
  20084. 026500         OR NEW-SKEY NOT EQUAL OLD-SKEY
  20085. 026600         PERFORM 500-SWA-TOTAL THRU 539-EXIT
  20086. 026700         PERFORM 215-SKEY-TO-HDR THRU 220-TOP-PAGE
  20087. 026800         GO TO 30-ADD-WRITE.
  20088. 026900     IF NEW-PASTURE NOT EQUAL OLD-PASTURE
  20089. 027000         PERFORM 500-SWA-TOTAL THRU 510-PASTURE-TOTAL
  20090. 027100         GO TO 30-ADD-WRITE.
  20091. 027200     IF NEW-SWA NOT EQUAL OLD-SWA
  20092. 027300         PERFORM 500-SWA-TOTAL.
  20093. 027400 30-ADD-WRITE.
  20094. 027500     PERFORM 700-SWA-ADD THRU 720-MOVE-TO-OUTPUT.
  20095. 027600     GO TO 20-READ-PROCESS.
  20096. 027700 200-HOUSEKEEP.
  20097. 027800     READY DIC-DE.
  20098. 027900     INITIALIZE COMBO-TABLE.
  20099. 028000     MOVE 1 TO FIRST-DATA-CONDITION.
  20100. 028100     MOVE ZERO TO EOF-CONDITION.
  20101. 028200     OPEN INPUT INPUT-FILE OUTPUT PRINT-OUT.
  20102. 028300     ACCEPT DATE-TODAY FROM DATE.
  20103. 028400     MOVE THIS-DAY TO DA-HDR.
  20104. 028500     MOVE THIS-MONTH TO MO-HDR.
  20105. 028600     MOVE THIS-YEAR TO YR-HDR.
  20106. 028700     PERFORM 210-READ-INPUT.
  20107. 028800     IF FILE-END
  20108. 028900         DISPLAY "NO RECORD IN INPUT FILE"
  20109. 029000         CLOSE INPUT-FILE PRINT-OUT
  20110. 029100         STOP RUN.
  20111. 029200     IF PASTURE-NUM EQUAL "00"
  20112. 029300         MOVE SPACES TO WS-PASTURE
  20113. 029400     ELSE MOVE PASTURE-NUM TO WS-PASTURE.
  20114. 029500     PERFORM 215-SKEY-TO-HDR THRU 220-TOP-PAGE.
  20115. 029600     PERFORM 700-SWA-ADD.
  20116. 029700     MOVE COMBO TO COMBO-ELEMENT ( 1 ).
  20117. 029800     MOVE ACR-DU TO TOTAL-ELEMENT ( 1 ).
  20118. 029900     PERFORM 720-MOVE-TO-OUTPUT.
  20119. 030000     MOVE SWA TO NEW-SWA.
  20120. 030100     MOVE PASTURE-NUM TO NEW-PASTURE.
  20121. 030200     MOVE ALLOT-NUM TO NEW-ALLOT.
  20122. 030300     MOVE BLM-ADM-U TO NEW-SKEY.
  20123. 030400 210-READ-INPUT.
  20124. 030500     READ INPUT-FILE
  20125. 030600         AT END MOVE 1 TO EOF-CONDITION
  20126. 030700         SUBTRACT 1 FROM READ-COUNT.
  20127. 030800     ADD 1 TO READ-COUNT.
  20128. 030900 215-SKEY-TO-HDR.
  20129. 031000     MOVE 0003 TO DE-NO-8801-DEC.
  20130. 031100     MOVE BLM-ADM-U TO DE-CD-8822-DEC.
  20131. 031200     FIND ANY CODE-DEC.
  20132. 031300     IF DB-STATUS NOT = ZERO
  20133. 031400         DISPLAY "BAD STATE CODE"  CALL "ABOR".
  20134. 031500     GET CODE-DEC.
  20135. 031600     MOVE DE-CD-NAM-8823-DEC TO DE-CD-NAM-8823-DEC-H.
  20136. 031700     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  20137. 031800     IF DB-STATUS NOT = ZERO
  20138. 031900         DISPLAY "BAD DIST, RA, PLU CODES"  CALL "ABOR".
  20139. 032000     GET CODE-EXPL-DECE.
  20140. 032100     MOVE DE-CD-EXPLN-8827-DECE TO DE-CD-EXPLN-8827-DECE-H.
  20141. 032200     MOVE ST-NAM-H TO STATE-NAME.
  20142. 032300     MOVE RA-NAM-H TO RA-NAME.
  20143. 032400     MOVE DIST-NAM-H TO DIST-NAME.
  20144. 032500     MOVE PLU-NAM-H TO PU-NAME.
  20145. 032600 220-TOP-PAGE.
  20146. 032700     ADD 1 TO PAGE-COUNT.
  20147. 032800     MOVE PAGE-COUNT TO PAGE-NO.
  20148. 032900     IF PAGE-COUNT = 1
  20149. 033000         DISPLAY PAG-HDR-1
  20150. 033100         DISPLAY PAG-HDR-3
  20151. 033200         DISPLAY PAG-HDR-4
  20152. 033300         DISPLAY PAG-HDR-5
  20153. 033400         DISPLAY PAG-HDR-6
  20154. 033500         DISPLAY COL-HDR-1
  20155. 033600         DISPLAY COL-HDR-2
  20156. 033700         DISPLAY SPACES.
  20157. 033800     WRITE PRINT-LINE FROM PAG-HDR-1
  20158. 033900         AFTER ADVANCING PAGE.
  20159. 034000     WRITE PRINT-LINE FROM PAG-HDR-3
  20160. 034100         AFTER ADVANCING 1 LINE.
  20161. 034200     WRITE PRINT-LINE FROM PAG-HDR-4
  20162. 034300         AFTER ADVANCING 1 LINE.
  20163. 034400     WRITE PRINT-LINE FROM PAG-HDR-5
  20164. 034500         AFTER ADVANCING 1 LINE.
  20165. 034600     WRITE PRINT-LINE FROM PAG-HDR-6
  20166. 034700         AFTER ADVANCING 1 LINE.
  20167. 034800     WRITE PRINT-LINE FROM COL-HDR-1
  20168. 034900         AFTER ADVANCING 1 LINE.
  20169. 035000     WRITE PRINT-LINE FROM COL-HDR-2
  20170. 035100         AFTER ADVANCING 1 LINE.
  20171. 035200     WRITE PRINT-LINE FROM WORK-SPACES
  20172. 035300         AFTER ADVANCING 1 LINE.
  20173. 035400     MOVE 9 TO LINE-COUNT.
  20174. 035500 225-SKEY-CHANGE.
  20175. 035600     MOVE NEW-SKEY TO OLD-SKEY.
  20176. 035700     MOVE BLM-ADM-U TO NEW-SKEY.
  20177. 035800 230-ALLOT-CHANGE.
  20178. 035900     MOVE NEW-ALLOT TO OLD-ALLOT.
  20179. 036000     MOVE ALLOT-NUM TO NEW-ALLOT.
  20180. 036100 240-PASTURE-CHANGE.
  20181. 036200     MOVE NEW-PASTURE TO OLD-PASTURE.
  20182. 036300     MOVE PASTURE-NUM TO NEW-PASTURE.
  20183. 036400 250-SWA-CHANGE.
  20184. 036500     MOVE NEW-SWA TO OLD-SWA.
  20185. 036600     MOVE SWA TO NEW-SWA.
  20186. 036700 260-WRITE-OUTPUT.
  20187. 036800     IF LINE-COUNT GREATER 54
  20188. 036900         PERFORM 220-TOP-PAGE.
  20189. 037000     IF PAGE-COUNT = 1
  20190. 037100         DISPLAY WORK-PRINT.
  20191. 037200     WRITE PRINT-LINE FROM WORK-PRINT
  20192. 037300         AFTER ADVANCING 1 LINE.
  20193. 037400     ADD 1 TO LINE-COUNT.
  20194. 037500 500-SWA-TOTAL.
  20195. 037600     MOVE SPACES TO WORK-PRINT.
  20196. 037700     PERFORM 260-WRITE-OUTPUT.
  20197. 037800     MOVE SAVE-ALLOTMENT TO ALLT-P.
  20198. 037900     MOVE SAVE-PASTURE TO PASTR-P.
  20199. 038000     MOVE TOTAL-SWA-ACRES TO TOTL-ACRS.
  20200. 038100     MOVE SWA-TOTAL-LINE TO WORK-PRINT.
  20201. 038200     PERFORM 260-WRITE-OUTPUT.
  20202. 038300     ADD TOTAL-SWA-ACRES TO TOTAL-PASTURE-ACRES.
  20203. 038400     MOVE ZEROS TO TOTAL-SWA-ACRES.
  20204. 038500     MOVE 1 TO FIRST-DATA-CONDITION.
  20205. 038600 510-PASTURE-TOTAL.
  20206. 038700     MOVE SPACES TO WORK-PRINT.
  20207. 038800     PERFORM 260-WRITE-OUTPUT.
  20208. 038900     MOVE SAVE-ALLOTMENT TO ALLOT-P.
  20209. 039000     MOVE TOTAL-PASTURE-ACRES TO ACRS-P.
  20210. 039100     MOVE PASTURE-TOTAL-LINE TO WORK-PRINT.
  20211. 039200     PERFORM 260-WRITE-OUTPUT.
  20212. 039300     ADD TOTAL-PASTURE-ACRES TO TOTAL-ALLOT-ACRES.
  20213. 039400     MOVE ZEROS TO TOTAL-PASTURE-ACRES.
  20214. 039500 520-ALLOT-TOTAL.
  20215. 039600     MOVE SPACES TO WORK-PRINT.
  20216. 039700     PERFORM 260-WRITE-OUTPUT.
  20217. 039800     MOVE TOTAL-ALLOT-ACRES TO ACRES-P OF ALLOTMENT-TOTAL-LINE.
  20218. 039900     MOVE ALLOTMENT-TOTAL-LINE TO WORK-PRINT.
  20219. 040000     PERFORM 260-WRITE-OUTPUT.
  20220. 040100     MOVE ZEROS TO TOTAL-ALLOT-ACRES.
  20221. 040200     MOVE SPACES TO WORK-PRINT.
  20222. 040300     PERFORM 260-WRITE-OUTPUT.
  20223. 040400 530-OWN-SUM.
  20224. 040500     ADD 1 TO SUB-SCRIPT.
  20225. 040600     IF SUB-SCRIPT > SUB-CHK
  20226. 040700         MOVE SUB-SCRIPT TO SUB-CHK.
  20227. 040800     IF COMBO-ELEMENT ( SUB-SCRIPT ) EQUAL SPACES
  20228. 040900         OR SUB-SCRIPT GREATER 200
  20229. 041000         GO TO 535-FINISH.
  20230. 041100     IF SUB-SCRIPT EQUAL 1
  20231. 041200         MOVE TOTAL-ELEMENT ( 1 ) TO ACRE-SUM-P
  20232. 041300         MOVE OWNER-ELEMENT ( 1 ) TO OWNR-SUM-P
  20233. 041400         MOVE JURIS-ELEMENT ( 1 ) TO JURIS-SUM-P
  20234. 041500         MOVE ADMIN-ELEMENT ( 1 ) TO ADMIN-SUM-P
  20235. 041600         MOVE LAND-TYPE-ELEMENT ( 1 ) TO LND-TYP-SUM-P
  20236. 041700         MOVE OWNER-SUMMARY-LINE-1 TO WORK-PRINT
  20237. 041800         PERFORM 260-WRITE-OUTPUT
  20238. 041900         GO TO 530-OWN-SUM.
  20239. 042000     IF SUB-SCRIPT EQUAL 2
  20240. 042100         MOVE TOTAL-ELEMENT ( 2 ) TO ACRE-SUM-2
  20241. 042200         MOVE OWNER-ELEMENT ( 2 ) TO OWNR-SUM-2
  20242. 042300         MOVE JURIS-ELEMENT ( 2 ) TO JURIS-SUM-2
  20243. 042400         MOVE ADMIN-ELEMENT ( 2 ) TO ADMIN-SUM-2
  20244. 042500         MOVE LAND-TYPE-ELEMENT ( 2 ) TO LND-TYP-SUM-2
  20245. 042600         MOVE OWNER-SUMMARY-LINE-2 TO WORK-PRINT
  20246. 042700         PERFORM 260-WRITE-OUTPUT
  20247. 042800         GO TO 530-OWN-SUM.
  20248. 042900     MOVE TOTAL-ELEMENT ( SUB-SCRIPT ) TO ACRE-SUM-3.
  20249. 043000     MOVE OWNER-ELEMENT ( SUB-SCRIPT ) TO OWNR-SUM-3.
  20250. 043100     MOVE JURIS-ELEMENT ( SUB-SCRIPT ) TO JURIS-SUM-3.
  20251. 043200     MOVE ADMIN-ELEMENT ( SUB-SCRIPT ) TO ADMIN-SUM-3.
  20252. 043300     MOVE LAND-TYPE-ELEMENT ( SUB-SCRIPT ) TO LND-TYP-SUM-3.
  20253. 043400     MOVE OWNER-SUMMARY-LINE-3 TO WORK-PRINT
  20254. 043500     PERFORM 260-WRITE-OUTPUT
  20255. 043600     GO TO 530-OWN-SUM.
  20256. 043700 535-FINISH.
  20257. 043800     IF SUB-SCRIPT EQUAL 2
  20258. 043900         MOVE OWNER-LINE2-SPACES TO WORK-PRINT
  20259. 044000         PERFORM 260-WRITE-OUTPUT.
  20260. 044100 536-RE-INITIALIZE.
  20261. 044200     MOVE ZEROS TO SUB-SCRIPT.
  20262. 044300     INITIALIZE COMBO-TABLE.
  20263. 044400 539-EXIT.
  20264. 044500 700-SWA-ADD.
  20265. 044600     ADD ACR-DU TO TOTAL-SWA-ACRES.
  20266. 044700 710-COMBO-ADD.
  20267. 044800     ADD 1 TO FIND-SCRIPT.
  20268. 044900     IF FIND-SCRIPT GREATER 200
  20269. 045000         DISPLAY "TABLE TOO SMALL"
  20270. 045100         DISPLAY "RECOMPILE AND RERUN"
  20271. 045200         CALL "TBLE-TOO-SMALL".
  20272. 045300     IF COMBO-ELEMENT ( FIND-SCRIPT ) EQUAL SPACES
  20273. 045400         MOVE COMBO TO COMBO-ELEMENT ( FIND-SCRIPT )
  20274. 045500         MOVE ACR-DU TO TOTAL-ELEMENT ( FIND-SCRIPT )
  20275. 045600         GO TO 712-SET-SCRIPT.
  20276. 045700     IF COMBO EQUAL COMBO-ELEMENT ( FIND-SCRIPT )
  20277. 045800         ADD ACR-DU TO TOTAL-ELEMENT ( FIND-SCRIPT )
  20278. 045900         GO TO 712-SET-SCRIPT.
  20279. 046000     GO TO 710-COMBO-ADD.
  20280. 046100 712-SET-SCRIPT.
  20281. 046200     MOVE ZEROS TO FIND-SCRIPT.
  20282. 046300 714-EXIT.
  20283. 046400 720-MOVE-TO-OUTPUT.
  20284. 046500     IF FIRST-DATA-LINE
  20285. 046600         MOVE SPACES TO DATA-LINE-2
  20286. 046700         MOVE ALLOT-NUM TO ALLOT-NO-P
  20287. 046800         MOVE SWA TO SWA-P
  20288. 046900         MOVE ZERO TO FIRST-DATA-CONDITION
  20289. 047000         MOVE SPACES TO WORK-PRINT
  20290. 047100         PERFORM 260-WRITE-OUTPUT
  20291. 047200         MOVE ALLOT-NUM TO SAVE-ALLOTMENT
  20292. 047300         MOVE WS-PASTURE TO SAVE-PASTURE
  20293. 047400         MOVE WS-PASTURE TO PASTURE-P
  20294. 047500     ELSE MOVE SPACES TO DATA-LINE-2.
  20295. 047600     IF LINE-COUNT GREATER 54
  20296. 047700         MOVE ALLOT-NUM TO ALLOT-NO-P
  20297. 047800         MOVE WS-PASTURE TO PASTURE-P
  20298. 047900         MOVE SWA TO SWA-P.
  20299. 048000     MOVE ACR-DU TO ACRES-P OF DATA-LINE-1.
  20300. 048100     MOVE OWN-TYP TO OWNER-P.
  20301. 048200     MOVE JURIS TO JURIS-P.
  20302. 048300     MOVE IN-ADMIN TO ADMIN-P.
  20303. 048400     MOVE LAND-TYP TO LAND-TYPE-P.
  20304. 048500     MOVE MAP-SRC TO MAP-SPCE-P.
  20305. 048600     MOVE IN-MTR-MER-CD TO MERID-P.
  20306. 048700     MOVE MTR-TWSHP TO TWNSHP-P.
  20307. 048800     MOVE IN-MTR-RNG TO RNGE-P.
  20308. 048900     MOVE IN-SEC-SECT TO SECT-P.
  20309. 049000     MOVE DATA-LINE-1 TO WORK-PRINT.
  20310. 049100     ADD 1 TO DATA-PRINT-COUNT.
  20311. 049200     PERFORM 260-WRITE-OUTPUT.
  20312. 049300 900-WRAPUP.
  20313. 049400     DISPLAY "INPUT RCDS= " READ-COUNT.
  20314. 049500     DISPLAY "PAGES PRINTED= " PAGE-NO.
  20315. 049600     DISPLAY "THIS IS A CHECK OF THE LARGEST TABLE SIZE"
  20316. 049700     DISPLAY "    REQUIRED FOR THIS RUN."   "SUB= " SUB-CHK.
  20317. 049800     PERFORM 500-SWA-TOTAL THRU 535-FINISH.
  20318. 049900     FINISH DIC-DE.
  20319. 050000     CLOSE INPUT-FILE PRINT-OUT.
  20320. 000000*-----------------------------------------------------------------
  20321. 000100 IDENTIFICATION DIVISION.
  20322. 000200 PROGRAM-ID. ES512Z.
  20323. 000300*        ACRES BY STRATUM COMPUTATION.
  20324. 000400*
  20325. 000500 AUTHOR. LEN SHEA.
  20326. 000600 DATE-WRITTEN. 7 FEB 83.
  20327. 000700 DATE-COMPILED.
  20328. 000800 ENVIRONMENT DIVISION.
  20329. 000900 CONFIGURATION SECTION.
  20330. 001000 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  20331. 001100 OBJECT-COMPUTER.  LEVEL-66-ASCII.
  20332. 001200 INPUT-OUTPUT SECTION.
  20333. 001300 FILE-CONTROL.
  20334. 001400     SELECT VA1Z-IN    ASSIGN TO I1
  20335. 001500         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  20336. 001600     SELECT VB1Z-IN    ASSIGN TO I2
  20337. 001700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  20338. 001800     SELECT VAFILE-OUT ASSIGN TO D1
  20339. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  20340. 002000 DATA DIVISION.
  20341. 002100 FILE SECTION.
  20342. 002200 FD  VA1Z-IN
  20343. 002300     CODE-SET IS GBCD
  20344. 002400     LABEL RECORDS ARE STANDARD.
  20345. 002500 01  VA-IN-REC                   PIC X(90).
  20346. 002600 FD  VB1Z-IN
  20347. 002700     CODE-SET IS GBCD
  20348. 002800     LABEL RECORDS ARE STANDARD.
  20349. 002900 01  VB-IN-REC                   PIC X(96).
  20350. 003000 FD  VAFILE-OUT
  20351. 003100     CODE-SET IS GBCD
  20352. 003200     LABEL RECORDS ARE STANDARD.
  20353. 003300 01  VAOUT-REC                   PIC X(132).
  20354. 003400 WORKING-STORAGE SECTION.
  20355. 003500 77  VA-REC-IN-CNT               PIC 9999 VALUE ZEROES.
  20356. 003600 77  VB-REC-IN-CNT               PIC 9999 VALUE ZEROES.
  20357. 003700 77  VA-REC-OUT-CNT              PIC 9999 VALUE ZEROES.
  20358. 003800 77  VA-SUB                      PIC 999  VALUE ZEROES.
  20359. 003900 77  VA-IN-EOF                   PIC XXX  VALUE " NO".
  20360. 004000 77  VB-IN-EOF                   PIC XXX  VALUE " NO".
  20361. 004100 77  VA-TBL-COUNT                PIC 999  VALUE ZEROES.
  20362. 004200 77  VAVB-SWA-MTCH               PIC XXX  VALUE " NO".
  20363. 004300 77  VB-MATCH                    PIC XXX  VALUE " NO".
  20364. 004400 01  VA-ACRES-COMP               PIC 9(5) VALUE ZEROES.
  20365. 004500 01  VA-REC-IN.
  20366. 004600     05  FILLER                  PIC X(48).
  20367. 004700     05  VA-SWA                  PIC XXXX.
  20368. 004800     05  FILLER                  PIC X(16).
  20369. 004900     05  VA-ACRES                PIC 9(5).
  20370. 005000     05  FILLER                  PIC X(17).
  20371. 005100 01  VB-REC-IN.
  20372. 005200     05  FILLER                  PIC X(28).
  20373. 005300     05  VB-SWA                  PIC XXXX.
  20374. 005400     05  FILLER                  PIC XX.
  20375. 005500     05  VB-SWA-PCT              PIC 9V99.
  20376. 005600     05  VB-SWA-PCT-R  REDEFINES  VB-SWA-PCT  PIC X(03).
  20377. 005700     05  VB-COPY-DATA1           PIC X(15).
  20378. 005800     05  FILLER                  PIC X(6).
  20379. 005900     05  VB-COPY-DATA2           PIC X(19).
  20380. 006000     05  FILLER                  PIC X(19).
  20381. 006100 01  VA-REC-OUT.
  20382. 006200     05  VA-REC-DATA             PIC X(90).
  20383. 006300     05  ACRES-STRAT             PIC 9(6) VALUE ZEROES.
  20384. 006400     05  VB-RECV-DATA1           PIC X(15).
  20385. 006500     05  VB-RECV-DATA2.
  20386. 006600         07  VAB-SWA-PCT  PIC X(03).
  20387. 006700         07  FILLER  PIC X(16).
  20388. 006800     05  FILLER                  PIC X(02).
  20389. 006900 01  VA-REC-TABLE.
  20390. 007000     05  VA-REC-HOLD   OCCURS 200.
  20391. 007100         10  FILLER              PIC X(48).
  20392. 007200         10  VA-SWA-HOLD         PIC XXXX.
  20393. 007300         10  FILLER              PIC X(16).
  20394. 007400         10  VA-ACRES-HOLD       PIC 9(5).
  20395. 007500         10  FILLER              PIC X(17).
  20396. 007600 PROCEDURE DIVISION.
  20397. 007700 0010-MAINLINE.
  20398. 007800     OPEN INPUT  VA1Z-IN, VB1Z-IN,
  20399. 007900          OUTPUT VAFILE-OUT.
  20400. 008000     PERFORM 0030-VA-READ.
  20401. 008100     IF VA-IN-EOF = "YES"
  20402. 008200         DISPLAY "VA FILE EMPTY"
  20403. 008300         PERFORM 9999-ABORT.
  20404. 008400     PERFORM 0040-VB-READ.
  20405. 008500     IF VB-IN-EOF = "YES"
  20406. 008600         DISPLAY "VB FILE EMPTY"
  20407. 008700         PERFORM 9999-ABORT.
  20408. 008800     PERFORM 0020-PROCESS THROUGH 0020-EXIT
  20409. 008900         UNTIL VB-IN-EOF = "YES"
  20410. 009000         AND VA-IN-EOF = "YES".
  20411. 009100     PERFORM STOP-RUN-NOW.
  20412. 009200 0020-PROCESS.
  20413. 009300     IF VA-SWA < VB-SWA
  20414. 009400          PERFORM 0060-VA-NOMATCH.
  20415. 009500     IF VA-SWA > VB-SWA
  20416. 009600         PERFORM 9998-ABORT.
  20417. 009700     IF VA-SWA = VB-SWA
  20418. 009800         MOVE "YES" TO VAVB-SWA-MTCH
  20419. 009900         PERFORM 0070-VA-TABLE-BUILD THRU 0070-EXIT.
  20420. 010000     PERFORM 0080-CALCULATE THROUGH 0080-EXIT.
  20421. 010100 0020-EXIT.
  20422. 010200     EXIT.
  20423. 010300 0030-VA-READ.
  20424. 010400     READ VA1Z-IN INTO VA-REC-IN
  20425. 010500     AT END MOVE "YES" TO VA-IN-EOF.
  20426. 010600     IF VA-IN-EOF = " NO"
  20427. 010700         ADD 1 TO VA-REC-IN-CNT.
  20428. 010800 0040-VB-READ.
  20429. 010900     READ VB1Z-IN INTO VB-REC-IN
  20430. 011000     AT END MOVE "YES" TO VB-IN-EOF.
  20431. 011100     IF VB-IN-EOF = " NO"
  20432. 011200         ADD 1 TO VB-REC-IN-CNT.
  20433. 011300 0050-WRITE-OUT-REC.
  20434. 011400     WRITE VAOUT-REC FROM VA-REC-OUT.
  20435. 011500     ADD 1 TO VA-REC-OUT-CNT.
  20436. 011600 0060-VA-NOMATCH.
  20437. 011700     DISPLAY "NO VB RECORD TO MATCH THIS VA RECORD: ".
  20438. 011800     DISPLAY VA-REC-IN.
  20439. 011900     PERFORM STOP-RUN-NOW.
  20440. 012000 0060-EXIT.
  20441. 012100     EXIT.
  20442. 012200 0070-VA-TABLE-BUILD.
  20443. 012300     MOVE 1 TO VA-SUB.
  20444. 012400     MOVE SPACES TO VA-REC-TABLE.
  20445. 012500 0070-VA-DATA-MOVE.
  20446. 012600     IF VA-SUB > 200  DISPLAY "INCREASE SIZE OF VA-REC-HOLD"
  20447. 012700         CALL "ABOR".
  20448. 012800     MOVE VA-REC-IN TO VA-REC-HOLD (VA-SUB).
  20449. 012900     PERFORM 0030-VA-READ.
  20450. 013000     IF VA-IN-EOF = "YES"
  20451. 013100         MOVE " NO" TO VAVB-SWA-MTCH
  20452. 013200             GO TO 0070-EXIT.
  20453. 013300     IF VA-SWA = VB-SWA
  20454. 013400         ADD 1 TO VA-SUB
  20455. 013500             GO TO 0070-VA-DATA-MOVE
  20456. 013600     ELSE
  20457. 013700         MOVE " NO" TO VAVB-SWA-MTCH.
  20458. 013800 0070-EXIT.
  20459. 013900     EXIT.
  20460. 014000 0080-CALCULATE.
  20461. 014100     MOVE VA-SUB TO VA-TBL-COUNT.
  20462. 014200     MOVE 1 TO VA-SUB.
  20463. 014300 0080-MULTIPLY.
  20464. 014400     MOVE VA-REC-HOLD (VA-SUB) TO VA-REC-OUT.
  20465. 014500     MOVE VB-COPY-DATA1 TO VB-RECV-DATA1.
  20466. 014600     MOVE VB-COPY-DATA2 TO VB-RECV-DATA2.
  20467. 014700     MOVE VB-SWA-PCT-R TO VAB-SWA-PCT.
  20468. 014800     COMPUTE ACRES-STRAT =
  20469. 014900         (VA-ACRES-HOLD (VA-SUB) * VB-SWA-PCT * 10).
  20470. 015000     PERFORM 0050-WRITE-OUT-REC.
  20471. 015100     ADD 1 TO VA-SUB.
  20472. 015200     IF VA-SUB > VA-TBL-COUNT
  20473. 015300         PERFORM 0040-VB-READ
  20474. 015400         MOVE 1 TO VA-SUB.
  20475. 015500     IF VB-IN-EOF = "YES"
  20476. 015600         GO TO 0080-EXIT.
  20477. 015700     IF VA-SWA-HOLD (VA-SUB) = VB-SWA
  20478. 015800         GO TO 0080-MULTIPLY.
  20479. 015900 0080-EXIT.
  20480. 016000     EXIT.
  20481. 016100 9998-ABORT.
  20482. 016200     DISPLAY "NO VA RECORD TO MATCH THIS VB RECORD: ".
  20483. 016300     DISPLAY VB-REC-IN.
  20484. 016400     PERFORM STOP-RUN-NOW.
  20485. 016500 9999-ABORT.
  20486. 016600     DISPLAY "VA OR VB FILE IS EMPTY, PROGRAM ABORTED."
  20487. 016700     PERFORM STOP-RUN-NOW.
  20488. 016800 STOP-RUN-NOW.
  20489. 016900     DISPLAY "VA INPUT RECORDS: " VA-REC-IN-CNT.
  20490. 017000     DISPLAY "VB INPUT RECORDS: " VB-REC-IN-CNT.
  20491. 017100     DISPLAY "VA OUTPUT RECORDS: " VA-REC-OUT-CNT.
  20492. 017200     CLOSE VA1Z-IN, VB1Z-IN, VAFILE-OUT.
  20493. 017300     STOP RUN.
  20494. 000000*-----------------------------------------------------------------
  20495. 000100 IDENTIFICATION DIVISION.
  20496. 000200 PROGRAM-ID. ES515P.
  20497. 000300*        ALLOTMENT RANGE CONDITION INFORMATION REPORT, P01A.
  20498. 000400*
  20499. 000500 AUTHOR. ROSE DAVIS, RON BAKER.
  20500. 000600 DATE-WRITTEN.   04/14/80.
  20501. 000700*DATE-REVISED.   MAR 1982.
  20502. 000800 DATE-COMPILED.
  20503. 000900 ENVIRONMENT DIVISION.
  20504. 001000 CONFIGURATION SECTION.
  20505. 001100 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  20506. 001200 OBJECT-COMPUTER.  LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
  20507. 001300 INPUT-OUTPUT SECTION.
  20508. 001400 FILE-CONTROL.
  20509. 001500 SELECT ACRE-STRATUM-FILE ASSIGN TO D1
  20510. 001600     ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  20511. 001700 SELECT PRINT-FILE ASSIGN TO P1-PRINTER
  20512. 001800     ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  20513. 001900 SELECT SORT-FILE ASSIGN TO S1.
  20514. 002000 DATA DIVISION.
  20515. 002100 SUB-SCHEMA SECTION.
  20516. 002200 DB  CODVAL2 WITHIN BLMDIC.
  20517. 002300 FILE SECTION.
  20518. 002400 FD  ACRE-STRATUM-FILE
  20519. 002500     CODE-SET IS GBCD
  20520. 002600     LABEL RECORDS ARE STANDARD
  20521. 002700     DATA RECORD IS ACRE-STRATUM-REC.
  20522. 002800 01  ACRE-STRATUM-REC.
  20523. 002900     03  REC-D1.
  20524. 003000         05  REC-TYP-D1    PIC X(02).
  20525. 003100         05  FMT-NUM-D1    PIC X.
  20526. 003200         05  FMT-CD-D1     PIC X.
  20527. 003300     03  ADM-UNIT-D1.
  20528. 003400         05  ST-D1         PIC X(02).
  20529. 003500         05  DIS-D1        PIC X(02).
  20530. 003600         05  RA-D1         PIC X(02).
  20531. 003700         05  PLU-D1        PIC X(02).
  20532. 003800     03  ALLOT-D1.
  20533. 003900         05  ALLOT-NUM-D1  PIC X(04).
  20534. 004000         05  PAST-NUM-D1   PIC X(02).
  20535. 004100     03  DATE-D1           PIC X(06).
  20536. 004200     03  ACT-D1            PIC X(01).
  20537. 004300     03  MAP-SRC-D1        PIC X(04).
  20538. 004400     03  MTR-MER-CD-D1     PIC X(02).
  20539. 004500     03  LINE-D1           PIC X(04).
  20540. 004600     03  MTR-TWN-D1        PIC X(05).
  20541. 004700     03  MTR-RNG-D1        PIC X(05).
  20542. 004800     03  SEC-D1            PIC X(03).
  20543. 004900     03  SWA-D1            PIC X(04).
  20544. 005000     03  ALIQ-PART-D1      PIC X(16).
  20545. 005100     03  ACRES-D1          PIC 9(05).
  20546. 005200     03  OWNER-D1          PIC X(04).
  20547. 005300     03  JURIS-D1          PIC X(04).
  20548. 005400     03  MGT-ADM-D1        PIC X(04).
  20549. 005500     03  LAND-TYP-D1       PIC X(04).
  20550. 005600     03  FILLER            PIC X(01).
  20551. 005700     03  ACRES-STRATUM-D1   PIC 9(06).
  20552. 005800     03  RNG-SITE-D1        PIC X(11).
  20553. 005900     03  STRATUM-D1         PIC XXXX.
  20554. 006000     03  GRP-D1.
  20555. 006100         05  VEG-SUB-TYP-D1 PIC X(04).
  20556. 006200         05  COND-CLS-D1        PIC X.
  20557. 006300         05  PCT-SLP-D1     PIC XXX.
  20558. 006400         05  ASPT-D1        PIC XX.
  20559. 006500         05  L-FORM-D1      PIC XXX.
  20560. 006600         05  SOIL-PHASE-D1  PIC X(6).
  20561. 006700     03  FILLER         PIC X(2).
  20562. 006800 FD  PRINT-FILE
  20563. 006900     CODE-SET IS GBCD
  20564. 007000     LABEL RECORDS ARE STANDARD
  20565. 007100     DATA RECORD IS PRINT-REC.
  20566. 007200 01  PRINT-REC  PIC X(132).
  20567. 007300 SD  SORT-FILE
  20568. 007400     DATA RECORDS ARE SORT-REC.
  20569. 007500 01  SORT-REC.
  20570. 007600     05  FILLER  PIC X(22).
  20571. 007700     05  SORT-KEY  PIC X(7).
  20572. 007800 WORKING-STORAGE SECTION.
  20573. 007900 77  FLAGG1  PIC 9 VALUE 0.
  20574. 008000 77  PAGECT  PIC 9(5) VALUE ZEROS.
  20575. 008100 77  LINECT  PIC 99 VALUE ZEROS.
  20576. 008200 77  10OT  PIC 9(6)V9.
  20577. 008300 77  11OT  PIC 9(6)V9.
  20578. 008400 77  12OT  PIC 9(6)V9.
  20579. 008500 77  13OT  PIC 9(7)V9.
  20580. 008600 77  14OT  PIC 9(7)V9.
  20581. 008700 77  15OT  PIC 9(7)V9.
  20582. 008800 77  16OT  PIC 9(7)V9.
  20583. 008900 77  17OT  PIC 9(7)V9.
  20584. 009000 77  18OT  PIC 9(7)V9.
  20585. 009100 77  20OT  PIC 9(7)V9.
  20586. 009200 77  21OT  PIC 9(7)V9.
  20587. 009300 77  22OT  PIC 9(7)V9.
  20588. 009400 77  24OT  PIC 9(7)V9.
  20589. 009500 77  25OT  PIC 9(7)V9.
  20590. 009600 77  26OT  PIC 9(7)V9.
  20591. 009700 77  28OT  PIC 9(7)V9.
  20592. 009800 77  29OT  PIC 9(7)V9.
  20593. 009900 77  30OT  PIC 9(7)V9.
  20594. 010000 77  32OT  PIC 9(7)V9.
  20595. 010100 77  33OT  PIC 9(7)V9.
  20596. 010200 77  34OT  PIC 9(7)V9.
  20597. 010300 77  32OTX  PIC 9(7)V9.
  20598. 010400 77  33OTX  PIC 9(7)V9.
  20599. 010500 77  34OTX  PIC 9(7)V9.
  20600. 010600 77  32OTXX  PIC 9(7)V9.
  20601. 010700 77  33OTXX  PIC 9(7)V9.
  20602. 010800 77  34OTXX  PIC 9(7)V9.
  20603. 010900 77  CNT-IN     PIC 9(8)  VALUE ZERO.
  20604. 011000 77  DET-CNT     PIC 9(8)  VALUE ZERO.
  20605. 011100 77  TEST-CNT   PIC 9(8)  VALUE 99999999.
  20606. 011200 01  HOLD-AREA.
  20607. 011300     03  ADST-DIST-RA-PLU-CDS-H.
  20608. 011400         05  ADSTDSRA-CD-H.
  20609. 011500             07  ADST-CD-H  PIC XX.
  20610. 011600             07  DIST-CD-H  PIC XX.
  20611. 011700             07  RA-CD-H  PIC XX.
  20612. 011800         05  PLU-CD-H  PIC XX.
  20613. 011900     03  CE-CD-EXPL-LIN-H.
  20614. 012000         05  DIST-NAM-H  PIC X(12).
  20615. 012100         05  RA-NAM-H  PIC X(13).
  20616. 012200         05  PLU-NAM-H  PIC X(15).
  20617. 012300     03  CT-FUNC-NAM-H.
  20618. 012400         05  ST-NAM-H  PIC X(10).
  20619. 012500         05  FILLER  PIC X(14).
  20620. 012600 01  ALOT-H  PIC X(4).
  20621. 012700 01  31H  PIC X(6).
  20622. 012800 01  RS-S-VST-CC-H  PIC X(20).
  20623. 012900 01  ACRE-STRATUM-REC-HLD.
  20624. 013000     05  REC-TYPE-W  PIC X(4).
  20625. 013100     05  SDRP-W.
  20626. 013200         07  SDR-W.
  20627. 013300             09  SD-W.
  20628. 013400                 11  ST-W   PIC XX.
  20629. 013500                 11  DS-W   PIC XX.
  20630. 013600             09  RA-W      PIC XX.
  20631. 013700         07  PU-W      PIC XX.
  20632. 013800     05  ALLOT-W.
  20633. 013900         07  ALOT-W  PIC X(04).
  20634. 014000         07  PAST-NUM-W   PIC X(02).
  20635. 014100     05  FILLER            PIC X(30).
  20636. 014200     05  SWA-W            PIC X(04).
  20637. 014300     05  FILLER           PIC X(16).
  20638. 014400     05  ACRES-SWA-W      PIC 9(05).
  20639. 014500     05  OWNER-W           PIC X(04).
  20640. 014600     05  JURIS-W           PIC X(04).
  20641. 014700     05  MGT-ADM-W         PIC X(04).
  20642. 014800     05  LAND-TYP-W        PIC X(04).
  20643. 014900     05  FILLER            PIC X.
  20644. 015000     05  ACRES-W           PIC X(06).
  20645. 015100     05  ACRES-W-RD REDEFINES ACRES-W PIC 9(05)V9.
  20646. 015200     05  RS-S-VST-CC.
  20647. 015300         10  RNG-SITE-W.
  20648. 015400             15  RNG-SITE-W1  PIC X(5).
  20649. 015500             15  RNG-SITE-W2  PIC X(2).
  20650. 015600             15  RNG-SITE-W3  PIC X(4).
  20651. 015700         10  STRAT-W  PIC X(4).
  20652. 015800         10  VEG-SUB-TYP-W  PIC X(4).
  20653. 015900         10  COND-CLASS-W  PIC X.
  20654. 016000     05  PCT-SLP-W     PIC XXX.
  20655. 016100     05  ASPT-W        PIC XX.
  20656. 016200     05  L-FORM-W      PIC XXX.
  20657. 016300     05  SOIL-PHASE-W  PIC X(6).
  20658. 016400     05  FILLER         PIC X(2).
  20659. 016500 01  PW1  PIC 9V9999.
  20660. 016600 01  PW1X REDEFINES PW1  PIC 999V99.
  20661. 016700 01  DATE-IN.
  20662. 016800     05  YY  PIC XX.
  20663. 016900     05  MM  PIC XX.
  20664. 017000     05  DD  PIC XX.
  20665. 017100 01  COND-CLASSW.
  20666. 017200     05  COND-CLASS-CCW  PIC X.
  20667. 017300     05  FILLER  PIC X(5) VALUE SPACES.
  20668. 017400     05  40OT  PIC 9(7)V9.
  20669. 017500     05  41OT  PIC 9(7)V9.
  20670. 017600     05  KEY-2.
  20671. 017700         10  KEY-CCW  PIC X VALUE "2".
  20672. 017800         10  COND-CLASS-KEY-CCW  PIC X.
  20673. 017900         10  FILLER  PIC X(5) VALUE SPACES.
  20674. 018000 01  SOIL-SERIESW.
  20675. 018100     05  SOIL-SER-SSW  PIC X(6).
  20676. 018200     05  FILLER  PIC X VALUE ZERO.
  20677. 018300     05  44OT  PIC 9(6)V9.
  20678. 018400     05  FILLER  PIC X VALUE ZERO.
  20679. 018500     05  45OT  PIC 9(6)V9.
  20680. 018600     05  KEY-3.
  20681. 018700         10  KEY-SS  PIC X VALUE "3".
  20682. 018800         10  SOIL-SER-KEY-SSW  PIC X(6).
  20683. 018900 01  STRATUMW.
  20684. 019000     05  STRAT-SW  PIC X(4).
  20685. 019100     05  FILLER  PIC XX VALUE SPACE.
  20686. 019200     05  36OT  PIC 9(7)V9.
  20687. 019300     05  37OT  PIC 9(7)V9.
  20688. 019400     05  KEY-1.
  20689. 019500         10  KEY-STR  PIC X VALUE "1".
  20690. 019600         10  STRAT-KEY-SW PIC X(4).
  20691. 019700         10  FILLER       PIC XX.
  20692. 019800 01  HD1.
  20693. 019900     03  FILLER        PIC X(13) VALUE "REPORT DATE: ".
  20694. 020000     03  HD-MM  PIC XX.
  20695. 020100     03  FILLER  PIC X VALUE "/".
  20696. 020200     03  HD-DD  PIC XX.
  20697. 020300     03  FILLER  PIC X VALUE "/".
  20698. 020400     03  HD-YY  PIC XX.
  20699. 020500     03  FILLER        PIC X(28) VALUE SPACES.
  20700. 020600     03  FILLER        PIC X(23) VALUE "U.S.D.I. BUREAU OF LAND".
  20701. 020700     03  FILLER        PIC X(11) VALUE " MANAGEMENT".
  20702. 020800     03  FILLER        PIC X(22) VALUE SPACES.
  20703. 020900     03  FILLER        PIC X(15) VALUE "PCN: P01A      ".
  20704. 021000     03  FILLER        PIC X(6) VALUE " PAGE ".
  20705. 021100     03  HDR-PG        PIC  ZZ,ZZ9.
  20706. 021200 01  HD3.
  20707. 021300     05  FILLER  PIC X(19) VALUE
  20708. 021400-        "   STATE           ".
  20709. 021500     05  HD4-ST  PIC X(35) VALUE
  20710. 021600-        "WYOMING                            ".
  20711. 021700     05  FILLER  PIC X(25) VALUE
  20712. 021800-        "ECOLOGICAL SITE INVENTORY".
  20713. 021900     05  FILLER  PIC X(38) VALUE SPACES.
  20714. 022000     05  FILLER  PIC X(06)
  20715. 022100         VALUE SPACE.
  20716. 022200     05  FILLER  PIC X(09)
  20717. 022300         VALUE SPACE.
  20718. 022400 01  HD4.
  20719. 022500     05  FILLER  PIC X(19) VALUE
  20720. 022600-        "   DISTRICT        ".
  20721. 022700     05  HD4-DS  PIC X(20) VALUE "ROCK SPRINGS".
  20722. 022800     05  FILLER  PIC X(93) VALUE SPACES.
  20723. 022900 01  HD5.
  20724. 023000     05  FILLER  PIC X(19) VALUE "   RESOURCE AREA   ".
  20725. 023100     05  HD5-RA  PIC X(20) VALUE "SALT WELLS         ".
  20726. 023200     05  FILLER  PIC X(8) VALUE SPACES.
  20727. 023300     05  HD5-NAME  PIC X(37) VALUE
  20728. 023400         "ALLOTMENT RANGE CONDITION INFORMATION".
  20729. 023500     05  FILLER  PIC X(48) VALUE SPACES.
  20730. 023600 01  HD6.
  20731. 023700     05  FILLER  PIC X(14) VALUE "   ALLOTMENT  ".
  20732. 023800     05  HD6-ALOT  PIC X(4).
  20733. 023900     05  FILLER  PIC X(114) VALUE SPACES.
  20734. 024000 01  HD7.
  20735. 024100     05  FILLER  PIC X(94) VALUE SPACES.
  20736. 024200     05  FILLER  PIC X(29) VALUE
  20737. 024300         "-------STRATUM  ACREAGE------".
  20738. 024400     05  FILLER  PIC X(9) VALUE SPACES.
  20739. 024500 01  HD8.
  20740. 024600     05  FILLER  PIC X(43) VALUE SPACES.
  20741. 024700     05  FILLER  PIC X(42) VALUE
  20742. 024800         "VEGETAL        CONDITION         PHASE  OF".
  20743. 024900     05  FILLER  PIC X(47) VALUE SPACES.
  20744. 025000 01  HD9.
  20745. 025100     05  FILLER  PIC X(16) VALUE "         STRATUM".
  20746. 025200     05  FILLER  PIC X(18) VALUE "        RANGE SITE".
  20747. 025300     05  FILLER  PIC X(16) VALUE "        SUB-TYPE".
  20748. 025400     05  FILLER  PIC X(15) VALUE "          CLASS".
  20749. 025500     05  FILLER  PIC X(21) VALUE "          SOIL SERIES".
  20750. 025600     05  FILLER  PIC X(11) VALUE "        BLM".
  20751. 025700     05  FILLER  PIC X(14) VALUE "         OTHER".
  20752. 025800     05  FILLER  PIC X(21) VALUE "         TOTAL       ".
  20753. 025900 01  HD10.
  20754. 026000     05  FILLER  PIC X(82) VALUE SPACES.
  20755. 026100     05  FILLER  PIC X(33) VALUE
  20756. 026200-        "ALLOTMENT RANGE CONDITION SUMMARY".
  20757. 026300     05  FILLER  PIC X(17) VALUE SPACES.
  20758. 026400 01  DATA1.
  20759. 026500     05  FILLER  PIC X(10) VALUE SPACES.
  20760. 026600     05  STRAT-P  PIC X(4).
  20761. 026700     05  FILLER  PIC X(10) VALUE SPACES.
  20762. 026800     05  RNG-SITE-P  PIC X(11).
  20763. 026900     05  FILLER  PIC X(9) VALUE SPACES.
  20764. 027000     05  VEG-SUB-TYP-P  PIC X(4).
  20765. 027100     05  FILLER  PIC X(14) VALUE SPACES.
  20766. 027200     05  COND-CLASS-P  PIC X.
  20767. 027300     05  FILLER  PIC X(14) VALUE SPACES.
  20768. 027400     05  SOIL-SER-P  PIC X(6).
  20769. 027500     05  FILLER  PIC X(5) VALUE SPACES.
  20770. 027600     05  10PT  PIC ZZZ,ZZZ.9.
  20771. 027700     05  FILLER  PIC X(5) VALUE SPACES.
  20772. 027800     05  11PT  PIC ZZZ,ZZZ.9.
  20773. 027900     05  FILLER  PIC X(5) VALUE SPACES.
  20774. 028000     05  12PT  PIC ZZZ,ZZZ.9.
  20775. 028100     05  FILLER  PIC X(7) VALUE SPACES.
  20776. 028200 01  DATA2.
  20777. 028300     05  FILLER  PIC X(60) VALUE SPACES.
  20778. 028400     05  FILLER  PIC X(26) VALUE
  20779. 028500         "STRATUM SUB-TOTAL         ".
  20780. 028600     05  13PT  PIC Z,ZZZ,ZZZ.9.
  20781. 028700     05  FILLER  PIC X(3) VALUE SPACES.
  20782. 028800     05  14PT  PIC Z,ZZZ,ZZZ.9.
  20783. 028900     05  FILLER  PIC X(3) VALUE SPACES.
  20784. 029000     05  15PT  PIC Z,ZZZ,ZZZ.9.
  20785. 029100     05  FILLER  PIC X(7) VALUE SPACES.
  20786. 029200 01  DATA3.
  20787. 029300     05  FILLER  PIC X(60) VALUE SPACES.
  20788. 029400     05  FILLER  PIC X(26) VALUE
  20789. 029500         "ALLOTMENT ACREAGE TOTAL   ".
  20790. 029600     05  16PT  PIC Z,ZZZ,ZZZ.9.
  20791. 029700     05  FILLER  PIC X(3) VALUE SPACES.
  20792. 029800     05  17PT  PIC Z,ZZZ,ZZZ.9.
  20793. 029900     05  FILLER  PIC X(3) VALUE SPACES.
  20794. 030000     05  18PT  PIC Z,ZZZ,ZZZ.9.
  20795. 030100     05  FILLER  PIC X(7) VALUE SPACES.
  20796. 030200 01  DATA4.
  20797. 030300      05  FILLER  PIC X(70) VALUE SPACES.
  20798. 030400      05  19-31PT  PIC X(10).
  20799. 030500      05  FILLER  PIC X(5) VALUE SPACES.
  20800. 030600      05  20-32PT  PIC Z,ZZZ,ZZZ.9.
  20801. 030700      05  FILLER  PIC X(3) VALUE SPACES.
  20802. 030800      05  21-33PT  PIC Z,ZZZ,ZZZ.9.
  20803. 030900      05  FILLER  PIC X(3) VALUE SPACES.
  20804. 031000      05  22-34PT  PIC Z,ZZZ,ZZZ.9.
  20805. 031100      05  FILLER  PIC X VALUE SPACE.
  20806. 031200      05  PERCENT  PIC ZZZ.99.
  20807. 031300      05  FILLER  PIC X VALUE "%".
  20808. 031400******WORKING AREA FOR OUTPUT********
  20809. 031500 01  KEYR1H  PIC 9 VALUE ZERO.
  20810. 031600 01  36RH  PIC 9(8)V9 VALUE ZEROS.
  20811. 031700 01  37RH  PIC 9(8)V9 VALUE ZEROS.
  20812. 031800 01  38RH  PIC 9(8)V9.
  20813. 031900 01  36RHT  PIC 9(9)V9 VALUE ZEROS.
  20814. 032000 01  37RHT  PIC 9(9)V9 VALUE ZEROS.
  20815. 032100 01  38RHT  PIC 9(9)V9.
  20816. 032200 01  35-43RH  PIC X(6).
  20817. 032300 01  HOLD-SORT-REC.
  20818. 032400     05  35-43R.
  20819. 032500         10  39R  PIC X.
  20820. 032600         10  FILLER  PIC X(5).
  20821. 032700     05  36R  PIC 9(7)V9.
  20822. 032800     05  37R  PIC 9(7)V9.
  20823. 032900     05  KEYR.
  20824. 033000         10  KEYR1  PIC 9.
  20825. 033100         10  KEYR2  PIC X(6).
  20826. 033200 01  35R.
  20827. 033300     05  35R1  PIC X(3) VALUE SPACES.
  20828. 033400     05  35R2  PIC X(6).
  20829. 033500     05  35R3  PIC X(1) VALUE SPACES.
  20830. 033600 01  43R.
  20831. 033700     05  43R1  PIC X(2) VALUE SPACES.
  20832. 033800     05  43R2  PIC X(6).
  20833. 033900     05  43R3  PIC X(2) VALUE SPACES.
  20834. 034000 01  HD1R.
  20835. 034100     05  FILLER  PIC X(54) VALUE SPACES.
  20836. 034200     05  HD1-NAME  PIC X(23) VALUE "    STRATUM SUMMARY    ".
  20837. 034300     05  FILLER  PIC X(55) VALUE SPACES.
  20838. 034400 01  HD2R.
  20839. 034500     05  FILLER  PIC X(77) VALUE SPACES.
  20840. 034600     05  FILLER  PIC X(42) VALUE
  20841. 034700-        "------------------ACREAGE-----------------".
  20842. 034800     05  FILLER  PIC X(13) VALUE SPACES.
  20843. 034900 01  HD3R.
  20844. 035000     05  FILLER  PIC X(26) VALUE SPACES.
  20845. 035100     05  HD3-NAME  PIC X(15) VALUE "    STRATUM    ".
  20846. 035200     05  FILLER  PIC X(39) VALUE SPACES.
  20847. 035300     05  FILLER  PIC X(3) VALUE "BLM".
  20848. 035400     05  FILLER  PIC X(13) VALUE SPACES.
  20849. 035500     05  FILLER  PIC X(5) VALUE "OTHER".
  20850. 035600     05  FILLER  PIC X(14) VALUE SPACES.
  20851. 035700     05  FILLER  PIC X(5) VALUE "TOTAL".
  20852. 035800     05  FILLER  PIC X(15) VALUE SPACES.
  20853. 035900 01  HD4R.
  20854. 036000     05  FILLER  PIC X(28) VALUE SPACES.
  20855. 036100     05  HD4-NAME  PIC X(10).
  20856. 036200     05  FILLER  PIC X(33) VALUE SPACES.
  20857. 036300     05  36-44R  PIC ZZ,ZZZ,ZZZ.9.
  20858. 036400     05  FILLER  PIC X(6) VALUE SPACES.
  20859. 036500     05  37-45R  PIC ZZ,ZZZ,ZZZ.9.
  20860. 036600     05  FILLER  PIC X(7) VALUE SPACES.
  20861. 036700     05  38-46R  PIC ZZ,ZZZ,ZZZ.9.
  20862. 036800     05  FILLER  PIC X(12) VALUE SPACES.
  20863. 036900 01  HD4RX.
  20864. 037000     05  FILLER  PIC X(28) VALUE SPACES.
  20865. 037100     05  HD4-NAMEX  PIC X(10).
  20866. 037200     05  FILLER  PIC X(33) VALUE SPACES.
  20867. 037300     05  36-44RX  PIC ZZ,ZZZ,ZZZ.9.
  20868. 037400     05  FILLER  PIC X(6) VALUE SPACES.
  20869. 037500     05  37-45RX  PIC ZZ,ZZZ,ZZZ.9.
  20870. 037600     05  FILLER  PIC X(7) VALUE SPACES.
  20871. 037700     05  38-46RX  PIC ZZ,ZZZ,ZZZ.9.
  20872. 037800     05  FILLER  PIC X(3) VALUE SPACES.
  20873. 037900     05  PERCENTS  PIC ZZZ.99.
  20874. 038000     05  FILLER  PIC X VALUE "%".
  20875. 038100     05  FILLER  PIC X(2) VALUE SPACES.
  20876. 038200 01  HD5R.
  20877. 038300     05  FILLER  PIC X(23) VALUE SPACES.
  20878. 038400     05  FILLER  PIC X(15) VALUE "RESOURCE TOTALS".
  20879. 038500     05  FILLER  PIC X(32) VALUE SPACES.
  20880. 038600     05  36-44RT  PIC ZZZ,ZZZ,ZZZ.9.
  20881. 038700     05  FILLER  PIC X(5) VALUE SPACES.
  20882. 038800     05  37-45RT  PIC ZZZ,ZZZ,ZZZ.9.
  20883. 038900     05  FILLER  PIC X(6) VALUE SPACES.
  20884. 039000     05  38-46RT  PIC ZZZ,ZZZ,ZZZ.9.
  20885. 039100     05  FILLER  PIC X(12) VALUE SPACES.
  20886. 039200 01  HD1RX.
  20887. 039300     05  FILLER  PIC X(19) VALUE "   RESOURCE AREA   ".
  20888. 039400     05  HD1RX-RA  PIC X(20)  VALUE "SALT WELLS          ".
  20889. 039500     05  FILLER  PIC X(15) VALUE SPACES.
  20890. 039600     05  HD1RX-NAME  PIC X(23) VALUE "    STRATUM SUMMARY    ".
  20891. 039700     05  FILLER  PIC X(39) VALUE SPACES.
  20892. 039800     05  FILLER  PIC X(8) VALUE "PAGE NO ".
  20893. 039900     05  PG-NOX  PIC ZZZZ9.
  20894. 040000     05  FILLER  PIC X(3) VALUE SPACES.
  20895. 040100 01  ST-NAM-HLD.
  20896. 040200     03  ST-NAME    PIC X(10).
  20897. 040300     03  FILLER      PIC X(14).
  20898. 040400 01  DRP-NAM-HLD.
  20899. 040500     03  DS-NAME    PIC X(10).
  20900. 040600     03  FILLER     PIC XX.
  20901. 040700     03  RA-NAME    PIC X(12).
  20902. 040800     03  FILLER     PIC X.
  20903. 040900     03  PU-NAME    PIC X(15).
  20904. 041000 01  FILE-STATUS.
  20905. 041100     03  MAJOR-STATUS    PIC X.
  20906. 041200     03  MINOR-STATUS    PIC X.
  20907. 041300     COPY DBSTATUS IN TPCOBOLIB.
  20908. 041400 PROCEDURE DIVISION.
  20909. 041500 SORT-STATEMENT SECTION.
  20910. 041600 SORT-STATEMENT-PARA.
  20911. 041700     SORT SORT-FILE ON ASCENDING KEY SORT-KEY,
  20912. 041800     INPUT PROCEDURE IS 100-INPUT,
  20913. 041900     OUTPUT PROCEDURE IS 600-OUTPUT.
  20914. 042000     FINISH DIC-DE.
  20915. 042100     STOP RUN.
  20916. 042200 100-INPUT SECTION.
  20917. 042300 110-INPUT.
  20918. 042400    OPEN INPUT ACRE-STRATUM-FILE
  20919. 042500         OUTPUT PRINT-FILE.
  20920. 042600     READY DIC-DE.
  20921. 042700    ACCEPT DATE-IN FROM DATE.
  20922. 042800    MOVE YY TO HD-YY.
  20923. 042900    MOVE MM TO HD-MM.
  20924. 043000    MOVE DD TO HD-DD.
  20925. 043100 120-READ1.
  20926. 043200    READ ACRE-STRATUM-FILE AT END GO TO 130-READ2.
  20927. 043300*   DISPLAY ACRE-STRATUM-REC.
  20928. 043400    MOVE ACRE-STRATUM-REC TO ACRE-STRATUM-REC-HLD.
  20929. 043500     MOVE SDRP-W TO ADST-DIST-RA-PLU-CDS-H.
  20930. 043600     PERFORM 590-DB-HDR THRU 590-EXIT.
  20931. 043700    MOVE ALOT-W TO ALOT-H, HD6-ALOT.
  20932. 043800    MOVE RS-S-VST-CC TO RS-S-VST-CC-H.
  20933. 043900    MOVE RNG-SITE-W TO RNG-SITE-P.
  20934. 044000    MOVE STRAT-W TO STRAT-P.
  20935. 044100    MOVE VEG-SUB-TYP-W TO VEG-SUB-TYP-P.
  20936. 044200    MOVE COND-CLASS-W TO COND-CLASS-P.
  20937. 044300*   IF RA-W = "48" MOVE "VALLEY  " TO HD5-RA, HD1RX-RA
  20938. 044400*   ELSE IF RA-W = "58" MOVE "PHILLIPS" TO HD5-RA, HD1RX-RA
  20939. 044500*   ELSE IF RA-W = "68" MOVE "HAVRE   " TO HD5-RA, HD1RX-RA
  20940. 044600*   ELSE DISPLAY "BAD RESOURCE AREA" SPACE ACRE-STRATUM-REC
  20941. 044700*       GO TO 120-READ1.
  20942. 044800    EXAMINE ACRES-W REPLACING ALL SPACES BY ZEROS.
  20943. 044900*   IF RNG-SITE-W2 = "27" MOVE "C" TO COND-CLASS-W.
  20944. 045000     IF SOIL-PHASE-W = "000110" MOVE "U" TO COND-CLASS-W.
  20945. 045100    MOVE ZEROS TO 13OT, 14OT, 16OT, 17OT,  20OT, 21OT,
  20946. 045200       24OT, 25OT, 28OT, 29OT, 32OT, 33OT, 36OT, 37OT,
  20947. 045300       40OT, 41OT, 44OT, 45OT, 32OTX, 33OTX, 32OTXX, 33OTXX.
  20948. 045400     PERFORM 310-ACREAGE THRU 310-ACREAGE-EXIT.
  20949. 045500     PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
  20950. 045600     PERFORM 400-HDGS1A THRU 400-HDGS1A-EXIT.
  20951. 045700 130-READ2.
  20952. 045800     READ ACRE-STRATUM-FILE AT END GO TO 510-CLOSE-INPUT.
  20953. 045900     ADD 1 TO CNT-IN.
  20954. 046000     IF CNT-IN > TEST-CNT GO TO 510-CLOSE-INPUT.
  20955. 046100*    DISPLAY ACRE-STRATUM-REC.
  20956. 046200     MOVE ACRE-STRATUM-REC TO ACRE-STRATUM-REC-HLD.
  20957. 046300    EXAMINE ACRES-W REPLACING ALL SPACES BY ZEROS.
  20958. 046400*   IF RNG-SITE-W2 = "27" MOVE "C" TO COND-CLASS-W.
  20959. 046500     IF SOIL-PHASE-W = "000110" MOVE "U" TO COND-CLASS-W.
  20960. 046600     IF ALOT-W = HD6-ALOT
  20961. 046700         PERFORM 150-P1 THRU 150-P1-EXIT
  20962. 046800         GO TO 130-READ2.
  20963. 046900     PERFORM 320-SOIL-SERIES THRU 320-SOIL-SER-EXIT.
  20964. 047000     PERFORM 300-COND-CK THRU 300-CC-EXIT.
  20965. 047100     PERFORM 330-STRATUM-CHG THRU 330-SC-EXIT.
  20966. 047200     PERFORM 340-ALLOTMENT-CHG THRU 340-AC-EXIT.
  20967. 047300     PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
  20968. 047400     PERFORM 400-HDGS1A THRU 400-HDGS1A-EXIT.
  20969. 047500     PERFORM 310-ACREAGE THRU 310-ACREAGE-EXIT.
  20970. 047600     GO TO 130-READ2.
  20971. 047700 150-P1.
  20972. 047800     IF (RS-S-VST-CC = RS-S-VST-CC-H) AND (SOIL-PHASE-W = 31H)
  20973. 047900        PERFORM 200-OWNR-CK THRU 200-OC-EXIT
  20974. 048000             GO TO 150-P1-EXIT.
  20975. 048100     IF (RS-S-VST-CC = RS-S-VST-CC-H) AND (SOIL-PHASE-W NOT = 31H)
  20976. 048200         PERFORM 320-SOIL-SERIES THRU 320-SOIL-SER-EXIT
  20977. 048300         PERFORM 300-COND-CK THRU 300-CC-EXIT
  20978. 048400         PERFORM 310-ACREAGE THRU 310-ACREAGE-EXIT
  20979. 048500         GO TO 150-P1-EXIT.
  20980. 048600     PERFORM 320-SOIL-SERIES THRU 320-SOIL-SER-EXIT.
  20981. 048700     PERFORM 300-COND-CK THRU 300-CC-EXIT.
  20982. 048800     PERFORM 330-STRATUM-CHG THRU 330-SC-EXIT.
  20983. 048900     PERFORM 310-ACREAGE THRU 310-ACREAGE-EXIT.
  20984. 049000 150-P1-EXIT.  EXIT.
  20985. 049100 200-OWNR-CK.
  20986. 049200         IF JURIS-W = "BLM" ADD ACRES-W-RD TO 10OT
  20987. 049300         ELSE ADD ACRES-W-RD TO 11OT.
  20988. 049400*    DISPLAY "10OT= " 10OT.
  20989. 049500 200-OC-EXIT.  EXIT.
  20990. 049600 300-COND-CK.
  20991. 049700     IF COND-CLASS-P = "E"
  20992. 049800        ADD 10OT TO 20OT  ADD 11OT TO 21OT
  20993. 049900     ELSE IF COND-CLASS-P = "G"
  20994. 050000        ADD 10OT TO 24OT  ADD 11OT TO 25OT
  20995. 050100     ELSE IF COND-CLASS-P = "F"
  20996. 050200        ADD 10OT TO 28OT  ADD 11OT TO 29OT
  20997. 050300     ELSE IF COND-CLASS-P = "P"
  20998. 050400        ADD 10OT TO 32OT  ADD 11OT TO 33OT
  20999. 050500     ELSE IF COND-CLASS-P = "C"
  21000. 050600        ADD 10OT TO 32OTXX  ADD 11OT TO 33OTXX
  21001. 050700     ELSE IF COND-CLASS-P = "U"
  21002. 050800        ADD 10OT TO 32OTX  ADD 11OT TO 33OTX
  21003. 050900        ELSE ADD 10OT TO 32OTX  ADD 11OT TO 33OTX.
  21004. 051000 300-CC-EXIT.  EXIT.
  21005. 051100 310-ACREAGE.
  21006. 051200     MOVE SOIL-PHASE-W TO 31H, SOIL-SER-P.
  21007. 051300     IF JURIS-W NOT = "BLM"
  21008. 051400         MOVE ACRES-W-RD TO 11OT
  21009. 051500         MOVE ZEROS TO 10OT
  21010. 051600     ELSE MOVE ACRES-W-RD TO 10OT
  21011. 051700         MOVE ZEROS TO 11OT.
  21012. 051800 310-ACREAGE-EXIT.  EXIT.
  21013. 051900 320-SOIL-SERIES.
  21014. 052000     IF SDR-W NOT = ADSTDSRA-CD-H
  21015. 052100         MOVE SDRP-W TO ADST-DIST-RA-PLU-CDS-H
  21016. 052200         PERFORM 590-DB-HDR THRU 590-EXIT.
  21017. 052300     IF LINECT > 53
  21018. 052400         PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT
  21019. 052500         PERFORM 400-HDGS1A THRU 400-HDGS1A-EXIT.
  21020. 052600     ADD 10OT, 11OT GIVING 12OT.
  21021. 052700     MOVE 10OT TO 10PT.
  21022. 052800     MOVE 11OT TO 11PT.
  21023. 052900     MOVE 12OT TO 12PT.
  21024. 053000     MOVE DATA1 TO PRINT-REC.
  21025. 053100     WRITE PRINT-REC.
  21026. 053200     ADD 1 TO LINECT.
  21027. 053300     ADD 1 TO DET-CNT.
  21028. 053400     MOVE SOIL-SER-P TO SOIL-SER-SSW, SOIL-SER-KEY-SSW.
  21029. 053500     MOVE 10OT TO 44OT.
  21030. 053600     MOVE 11OT TO 45OT.
  21031. 053700     RELEASE SORT-REC FROM SOIL-SERIESW.
  21032. 053800     ADD 10OT TO 13OT.
  21033. 053900     ADD 11OT TO 14OT.
  21034. 054000 320-SOIL-SER-EXIT.  EXIT.
  21035. 054100 330-STRATUM-CHG.
  21036. 054200    ADD 13OT, 14OT GIVING 15OT.
  21037. 054300    MOVE 13OT TO 13PT.
  21038. 054400    MOVE 14OT TO 14PT.
  21039. 054500    MOVE 15OT TO 15PT.
  21040. 054600     IF DET-CNT = 1
  21041. 054700         GO TO PASS-STRAT-TOT.
  21042. 054800    IF LINECT > 53
  21043. 054900        PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
  21044. 055000    MOVE DATA2 TO PRINT-REC.
  21045. 055100    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21046. 055200    MOVE SPACES TO PRINT-REC.
  21047. 055300    WRITE PRINT-REC.
  21048. 055400    ADD 3 TO LINECT.
  21049. 055500 PASS-STRAT-TOT.
  21050. 055600    MOVE ZERO TO DET-CNT.
  21051. 055700    ADD 13OT TO 16OT.
  21052. 055800    ADD 14OT TO 17OT.
  21053. 055900    MOVE STRAT-P TO STRAT-SW, STRAT-KEY-SW.
  21054. 056000    MOVE 13OT TO 36OT.
  21055. 056100    MOVE 14OT TO 37OT.
  21056. 056200    RELEASE SORT-REC FROM STRATUMW.
  21057. 056300    MOVE ZEROS TO 13OT, 14OT.
  21058. 056400    MOVE RS-S-VST-CC TO RS-S-VST-CC-H.
  21059. 056500    MOVE RNG-SITE-W TO RNG-SITE-P.
  21060. 056600    MOVE STRAT-W TO STRAT-P.
  21061. 056700    MOVE VEG-SUB-TYP-W TO VEG-SUB-TYP-P.
  21062. 056800    MOVE COND-CLASS-W TO COND-CLASS-P.
  21063. 056900 330-SC-EXIT.  EXIT.
  21064. 057000 340-ALLOTMENT-CHG.
  21065. 057100    IF LINECT > 53
  21066. 057200        PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
  21067. 057300    ADD 16OT, 17OT GIVING 18OT.
  21068. 057400    MOVE 16OT TO 16PT.
  21069. 057500    MOVE 17OT TO 17PT.
  21070. 057600    MOVE 18OT TO 18PT.
  21071. 057700    MOVE DATA3 TO PRINT-REC
  21072. 057800    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21073. 057900    ADD 2 TO LINECT.
  21074. 058000    ADD 20OT, 21OT GIVING 22OT.
  21075. 058100    ADD 24OT, 25OT GIVING 26OT.
  21076. 058200    ADD 28OT, 29OT GIVING 30OT.
  21077. 058300    ADD 32OT, 33OT GIVING 34OT.
  21078. 058400    ADD 32OTX, 33OTX GIVING 34OTX.
  21079. 058500    ADD 32OTXX, 33OTXX GIVING 34OTXX.
  21080. 058600    IF LINECT > 39
  21081. 058700        PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
  21082. 058800    MOVE HD10 TO PRINT-REC.
  21083. 058900    WRITE PRINT-REC AFTER 2 LINES.
  21084. 059000    MOVE "EXCELLENT " TO 19-31PT.
  21085. 059100    MOVE 20OT TO 20-32PT.
  21086. 059200    MOVE 21OT TO 21-33PT.
  21087. 059300    MOVE 22OT TO 22-34PT.
  21088. 059400    DIVIDE 18OT INTO 22OT GIVING PW1 ROUNDED.
  21089. 059500    PERFORM 500-CP THRU 500-CP-EXIT.
  21090. 059600    MOVE DATA4 TO PRINT-REC.
  21091. 059700    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21092. 059800    MOVE "GOOD      " TO 19-31PT.
  21093. 059900    MOVE 24OT TO 20-32PT.
  21094. 060000    MOVE 25OT TO 21-33PT.
  21095. 060100    MOVE 26OT TO 22-34PT.
  21096. 060200    DIVIDE 18OT INTO 26OT GIVING PW1 ROUNDED.
  21097. 060300    PERFORM 500-CP THRU 500-CP-EXIT.
  21098. 060400    MOVE DATA4 TO PRINT-REC.
  21099. 060500    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21100. 060600    MOVE "FAIR      " TO 19-31PT.
  21101. 060700    MOVE 28OT TO 20-32PT.
  21102. 060800    MOVE 29OT TO 21-33PT.
  21103. 060900    MOVE 30OT TO 22-34PT.
  21104. 061000    DIVIDE 18OT INTO 30OT GIVING PW1 ROUNDED.
  21105. 061100    PERFORM 500-CP THRU 500-CP-EXIT.
  21106. 061200    MOVE DATA4 TO PRINT-REC.
  21107. 061300    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21108. 061400    MOVE "POOR      " TO 19-31PT.
  21109. 061500    MOVE 32OT TO 20-32PT.
  21110. 061600    MOVE 33OT TO 21-33PT.
  21111. 061700    MOVE 34OT TO 22-34PT.
  21112. 061800    DIVIDE 18OT INTO 34OT GIVING PW1 ROUNDED.
  21113. 061900    PERFORM 500-CP THRU 500-CP-EXIT.
  21114. 062000    MOVE DATA4 TO PRINT-REC.
  21115. 062100    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21116. 062200    MOVE "CROPLAND  " TO 19-31PT.
  21117. 062300    MOVE 32OTXX TO 20-32PT.
  21118. 062400    MOVE 33OTXX TO 21-33PT.
  21119. 062500    MOVE 34OTXX TO 22-34PT.
  21120. 062600    DIVIDE 18OT INTO 34OTXX GIVING PW1 ROUNDED.
  21121. 062700    PERFORM 500-CP THRU 500-CP-EXIT.
  21122. 062800    MOVE DATA4 TO PRINT-REC.
  21123. 062900    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21124. 063000    MOVE "UNSUITABLE" TO 19-31PT.
  21125. 063100    MOVE 32OTX TO 20-32PT.
  21126. 063200    MOVE 33OTX TO 21-33PT.
  21127. 063300    MOVE 34OTX TO 22-34PT.
  21128. 063400    DIVIDE 18OT INTO 34OTX GIVING PW1 ROUNDED.
  21129. 063500    PERFORM 500-CP THRU 500-CP-EXIT.
  21130. 063600    MOVE DATA4 TO PRINT-REC.
  21131. 063700    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21132. 063800    MOVE "E" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21133. 063900    MOVE 20OT TO 40OT.
  21134. 064000    MOVE 21OT TO 41OT.
  21135. 064100    RELEASE SORT-REC FROM COND-CLASSW.
  21136. 064200    MOVE "G" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21137. 064300    MOVE 24OT TO 40OT.
  21138. 064400    MOVE 25OT TO 41OT.
  21139. 064500    RELEASE SORT-REC FROM COND-CLASSW.
  21140. 064600    MOVE "F" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21141. 064700    MOVE 28OT TO 40OT.
  21142. 064800    MOVE 29OT TO 41OT.
  21143. 064900    RELEASE SORT-REC FROM COND-CLASSW.
  21144. 065000    MOVE "P" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21145. 065100    MOVE 32OT TO 40OT.
  21146. 065200    MOVE 33OT TO 41OT.
  21147. 065300    RELEASE SORT-REC FROM COND-CLASSW.
  21148. 065400    MOVE "C" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21149. 065500    MOVE 32OTXX TO 40OT.
  21150. 065600    MOVE 33OTXX TO 41OT.
  21151. 065700    RELEASE SORT-REC FROM COND-CLASSW.
  21152. 065800    MOVE "U" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21153. 065900    MOVE 32OTX TO 40OT.
  21154. 066000    MOVE 33OTX TO 41OT.
  21155. 066100    RELEASE SORT-REC FROM COND-CLASSW.
  21156. 066200    MOVE ALOT-W TO ALOT-H, HD6-ALOT.
  21157. 066300    MOVE RS-S-VST-CC TO RS-S-VST-CC-H.
  21158. 066400    MOVE RNG-SITE-W TO RNG-SITE-P.
  21159. 066500    MOVE STRAT-W TO STRAT-P.
  21160. 066600    MOVE VEG-SUB-TYP-W TO VEG-SUB-TYP-P.
  21161. 066700    MOVE COND-CLASS-W TO COND-CLASS-P.
  21162. 066800    MOVE ZEROS TO 16OT, 17OT, 20OT, 21OT, 24OT, 25OT,
  21163. 066900        28OT, 29OT, 32OT, 33OT, 32OTX, 33OTX, 32OTXX, 33OTXX.
  21164. 067000 340-AC-EXIT.  EXIT.
  21165. 067100 400-HDGS1.
  21166. 067200    ADD 1 TO PAGECT.
  21167. 067300    MOVE PAGECT TO HDR-PG.
  21168. 067400    MOVE SPACES TO PRINT-REC.
  21169. 067500    WRITE PRINT-REC AFTER ADVANCING PAGE.
  21170. 067600    MOVE HD1 TO PRINT-REC.
  21171. 067700    WRITE PRINT-REC.
  21172. 067800    MOVE HD3 TO PRINT-REC.
  21173. 067900    WRITE PRINT-REC.
  21174. 068000    MOVE HD4 TO PRINT-REC.
  21175. 068100    WRITE PRINT-REC.
  21176. 068200    MOVE HD5 TO PRINT-REC.
  21177. 068300    WRITE PRINT-REC.
  21178. 068400    MOVE HD6 TO PRINT-REC.
  21179. 068500    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21180. 068600    MOVE 8 TO LINECT.
  21181. 068700 400-HDGS1-EXIT.  EXIT.
  21182. 068800 400-HDGS1A.
  21183. 068900    MOVE HD7 TO PRINT-REC.
  21184. 069000    WRITE PRINT-REC.
  21185. 069100    MOVE HD8 TO PRINT-REC.
  21186. 069200    WRITE PRINT-REC.
  21187. 069300    MOVE HD9 TO PRINT-REC.
  21188. 069400    WRITE PRINT-REC.
  21189. 069500    MOVE SPACES TO PRINT-REC.
  21190. 069600    WRITE PRINT-REC.
  21191. 069700    ADD 4 TO LINECT.
  21192. 069800 400-HDGS1A-EXIT.  EXIT.
  21193. 069900 500-CP.
  21194. 070000    MOVE PW1X TO PERCENT.
  21195. 070100 500-CP-EXIT.  EXIT.
  21196. 070200 510-CLOSE-INPUT.
  21197. 070300    IF LINECT > 50  PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT
  21198. 070400        PERFORM 400-HDGS1A THRU 400-HDGS1A-EXIT.
  21199. 070500    ADD 10OT, 11OT GIVING 12OT.
  21200. 070600     MOVE 10OT TO 10PT.
  21201. 070700     MOVE 11OT TO 11PT.
  21202. 070800     MOVE 12OT TO 12PT.
  21203. 070900    MOVE DATA1 TO PRINT-REC  WRITE PRINT-REC.
  21204. 071000    ADD 1 TO LINECT.
  21205. 071100    ADD 10OT TO 13OT  ADD 11OT TO 14OT.
  21206. 071200    ADD 13OT, 14OT GIVING 15OT.
  21207. 071300    MOVE 13OT TO 13PT.
  21208. 071400    MOVE 14OT TO 14PT.
  21209. 071500    MOVE 15OT TO 15PT.
  21210. 071600     IF DET-CNT = 1
  21211. 071700         GO TO 520-PASS-FINAL-STRAT-TOT.
  21212. 071800    MOVE DATA2 TO PRINT-REC
  21213. 071900    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21214. 072000    MOVE SPACES TO PRINT-REC.
  21215. 072100    WRITE PRINT-REC.
  21216. 072200    ADD 3 TO LINECT.
  21217. 072300 520-PASS-FINAL-STRAT-TOT.
  21218. 072400     MOVE ZERO TO DET-CNT.
  21219. 072500    ADD 13OT TO 16OT  ADD 14OT TO 17OT.
  21220. 072600    ADD 16OT, 17OT GIVING 18OT.
  21221. 072700    MOVE 16OT TO 16PT.
  21222. 072800    MOVE 17OT TO 17PT.
  21223. 072900    MOVE 18OT TO 18PT.
  21224. 073000    IF LINECT > 38  PERFORM 400-HDGS1 THRU 400-HDGS1-EXIT.
  21225. 073100    MOVE DATA3 TO PRINT-REC.
  21226. 073200    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21227. 073300    ADD 2 TO LINECT.
  21228. 073400     IF COND-CLASS-P = "E"
  21229. 073500        ADD 10OT TO 20OT  ADD 11OT TO 21OT
  21230. 073600     ELSE IF COND-CLASS-P = "G"
  21231. 073700        ADD 10OT TO 24OT  ADD 11OT TO 25OT
  21232. 073800     ELSE IF COND-CLASS-P = "F"
  21233. 073900        ADD 10OT TO 28OT  ADD 11OT TO 29OT
  21234. 074000     ELSE IF COND-CLASS-P = "P"
  21235. 074100        ADD 10OT TO 32OT  ADD 11OT TO 33OT
  21236. 074200     ELSE IF COND-CLASS-P = "C"
  21237. 074300        ADD 10OT TO 32OTXX  ADD 11OT TO 33OTXX
  21238. 074400     ELSE IF COND-CLASS-P = "U" ADD 10OT TO 32OTX
  21239. 074500         ADD 11OT TO 33OTX
  21240. 074600     ELSE ADD 10OT TO 32OTX ADD 11OT TO 33OTX.
  21241. 074700    ADD 20OT, 21OT GIVING 22OT.
  21242. 074800    ADD 24OT, 25OT GIVING 26OT.
  21243. 074900    ADD 28OT, 29OT GIVING 30OT.
  21244. 075000    ADD 32OT, 33OT GIVING 34OT.
  21245. 075100     ADD 32OTX, 33OTX GIVING 34OTX.
  21246. 075200    ADD 32OTXX, 33OTXX GIVING 34OTXX.
  21247. 075300    MOVE HD10 TO PRINT-REC.
  21248. 075400    WRITE PRINT-REC AFTER 2 LINES.
  21249. 075500    MOVE "EXCELLENT" TO 19-31PT.
  21250. 075600    MOVE 20OT TO 20-32PT.
  21251. 075700    MOVE 21OT TO 21-33PT.
  21252. 075800    MOVE 22OT TO 22-34PT.
  21253. 075900    DIVIDE 18OT INTO 22OT GIVING PW1 ROUNDED.
  21254. 076000    PERFORM 500-CP THRU 500-CP-EXIT.
  21255. 076100    MOVE DATA4 TO PRINT-REC.
  21256. 076200    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21257. 076300    MOVE "GOOD     " TO 19-31PT.
  21258. 076400    MOVE 24OT TO 20-32PT.
  21259. 076500    MOVE 25OT TO 21-33PT.
  21260. 076600    MOVE 26OT TO 22-34PT.
  21261. 076700    DIVIDE 18OT INTO 26OT GIVING PW1 ROUNDED.
  21262. 076800    PERFORM 500-CP THRU 500-CP-EXIT.
  21263. 076900    MOVE DATA4 TO PRINT-REC.
  21264. 077000    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21265. 077100    MOVE "FAIR     " TO 19-31PT.
  21266. 077200    MOVE 28OT TO 20-32PT.
  21267. 077300    MOVE 29OT TO 21-33PT.
  21268. 077400    MOVE 30OT TO 22-34PT.
  21269. 077500    DIVIDE 18OT INTO 30OT GIVING PW1 ROUNDED.
  21270. 077600    PERFORM 500-CP THRU 500-CP-EXIT.
  21271. 077700    MOVE DATA4 TO PRINT-REC.
  21272. 077800    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21273. 077900    MOVE "POOR     " TO 19-31PT.
  21274. 078000    MOVE 32OT TO 20-32PT.
  21275. 078100    MOVE 33OT TO 21-33PT.
  21276. 078200    MOVE 34OT TO 22-34PT.
  21277. 078300    DIVIDE 18OT INTO 34OT GIVING PW1 ROUNDED.
  21278. 078400    PERFORM 500-CP THRU 500-CP-EXIT.
  21279. 078500    MOVE DATA4 TO PRINT-REC.
  21280. 078600    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21281. 078700    MOVE "CROPLAND  " TO 19-31PT.
  21282. 078800    MOVE 32OTXX TO 20-32PT.
  21283. 078900    MOVE 33OTXX TO 21-33PT.
  21284. 079000    MOVE 34OTXX TO 22-34PT.
  21285. 079100    DIVIDE 18OT INTO 34OTXX GIVING PW1 ROUNDED.
  21286. 079200    PERFORM 500-CP THRU 500-CP-EXIT.
  21287. 079300    MOVE DATA4 TO PRINT-REC.
  21288. 079400    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21289. 079500    MOVE "UNSUITABLE" TO 19-31PT.
  21290. 079600    MOVE 32OTX TO 20-32PT.
  21291. 079700    MOVE 33OTX TO 21-33PT.
  21292. 079800    MOVE 34OTX TO 22-34PT.
  21293. 079900    DIVIDE 18OT INTO 34OTX GIVING PW1 ROUNDED.
  21294. 080000    PERFORM 500-CP THRU 500-CP-EXIT.
  21295. 080100    MOVE DATA4 TO PRINT-REC.
  21296. 080200    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21297. 080300     MOVE SOIL-SER-P TO SOIL-SER-SSW, SOIL-SER-KEY-SSW.
  21298. 080400     MOVE 10OT TO 44OT.
  21299. 080500     MOVE 11OT TO 45OT.
  21300. 080600     RELEASE SORT-REC FROM SOIL-SERIESW.
  21301. 080700    MOVE STRAT-P TO STRAT-SW, STRAT-KEY-SW.
  21302. 080800    MOVE 13OT TO 36OT.
  21303. 080900    MOVE 14OT TO 37OT.
  21304. 081000    RELEASE SORT-REC FROM STRATUMW.
  21305. 081100    MOVE "E" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21306. 081200    MOVE 20OT TO 40OT.
  21307. 081300    MOVE 21OT TO 41OT.
  21308. 081400    RELEASE SORT-REC FROM COND-CLASSW.
  21309. 081500    MOVE "G" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21310. 081600    MOVE 24OT TO 40OT.
  21311. 081700    MOVE 25OT TO 41OT.
  21312. 081800    RELEASE SORT-REC FROM COND-CLASSW.
  21313. 081900    MOVE "F" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21314. 082000    MOVE 28OT TO 40OT.
  21315. 082100    MOVE 29OT TO 41OT.
  21316. 082200    RELEASE SORT-REC FROM COND-CLASSW.
  21317. 082300    MOVE "P" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21318. 082400    MOVE 32OT TO 40OT.
  21319. 082500    MOVE 33OT TO 41OT.
  21320. 082600    RELEASE SORT-REC FROM COND-CLASSW.
  21321. 082700    MOVE "C" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21322. 082800    MOVE 32OTXX TO 40OT.
  21323. 082900    MOVE 33OTXX TO 41OT.
  21324. 083000    RELEASE SORT-REC FROM COND-CLASSW.
  21325. 083100    MOVE "U" TO COND-CLASS-CCW, COND-CLASS-KEY-CCW.
  21326. 083200    MOVE 32OTX TO 40OT.
  21327. 083300    MOVE 33OTX TO 41OT.
  21328. 083400    RELEASE SORT-REC FROM COND-CLASSW.
  21329. 083500    MOVE ZEROS TO LINECT.
  21330. 083600    CLOSE ACRE-STRATUM-FILE.
  21331. 083700 590-DB-HDR.
  21332. 083800     MOVE ADSTDSRA-CD-H TO DE-CD-8822-DEC.
  21333. 083900     MOVE 0003 TO DE-NO-8801-DEC.
  21334. 084000     FIND ANY CODE-DEC.
  21335. 084100     MOVE DB-STATUS TO DB-STAT.
  21336. 084200     IF  NOT OK
  21337. 084300         MOVE ADST-CD-H TO HD4-ST
  21338. 084400         MOVE DIST-CD-H TO HD4-DS
  21339. 084500         MOVE RA-CD-H TO HD5-RA HD1RX-RA
  21340. 084600             GO  TO 590-EXIT.
  21341. 084700     GET CODE-DEC.
  21342. 084800     MOVE DB-STATUS TO DB-STAT.
  21343. 084900     IF  NOT OK
  21344. 085000         MOVE ADST-CD-H TO HD4-ST
  21345. 085100         MOVE DIST-CD-H TO HD4-DS
  21346. 085200         MOVE RA-CD-H TO HD5-RA HD1RX-RA
  21347. 085300             GO  TO 590-EXIT.
  21348. 085400     MOVE DE-CD-NAM-8823-DEC TO ST-NAM-HLD.
  21349. 085500     MOVE ST-NAME TO HD4-ST.
  21350. 085600     FIND NEXT CODE-EXPL-DECE
  21351. 085700         WITHIN DEC-DECE.
  21352. 085800     MOVE DB-STATUS TO DB-STAT.
  21353. 085900     IF  NOT OK
  21354. 086000         MOVE DIST-CD-H TO HD4-DS
  21355. 086100         MOVE RA-CD-H TO HD5-RA HD1RX-RA
  21356. 086200             GO  TO 590-EXIT.
  21357. 086300     GET CODE-EXPL-DECE.
  21358. 086400     MOVE DB-STATUS TO DB-STAT.
  21359. 086500     IF  NOT OK
  21360. 086600         MOVE DIST-CD-H TO HD4-DS
  21361. 086700             GO  TO 590-EXIT.
  21362. 086800     MOVE DE-CD-EXPLN-8827-DECE TO DRP-NAM-HLD.
  21363. 086900     MOVE DS-NAME TO HD4-DS.
  21364. 087000     MOVE RA-NAME TO HD5-RA HD1RX-RA.
  21365. 087100 590-EXIT.
  21366. 087200     EXIT.
  21367. 087300 600-OUTPUT SECTION.
  21368. 087400 610-OUTPUT.
  21369. 087500 610-RETURN1.
  21370. 087600    RETURN SORT-FILE AT END GO TO 900-CLOSE.
  21371. 087700*    DISPLAY "SR= " SORT-REC.
  21372. 087800    MOVE SORT-REC TO HOLD-SORT-REC.
  21373. 087900    IF KEYR1 NOT = KEYR1H
  21374. 088000        PERFORM 700-HD-CKR THRU 700-EXIT
  21375. 088100        GO TO 610-RETURN1.
  21376. 088200    PERFORM 620-SUM-PROCESS THRU 620-SP-EXIT.
  21377. 088300    GO TO 610-RETURN1.
  21378. 088400 620-SUM-PROCESS.
  21379. 088500    IF 35-43R = 35-43RH
  21380. 088600        ADD 36R TO 36RH, 36RHT  ADD 37R TO 37RH, 37RHT
  21381. 088700        GO TO 620-SP-EXIT.
  21382. 088800    IF LINECT > 53 PERFORM 800-OFLO-HD2 THRU 800-EXIT.
  21383. 088900    ADD 36RH, 37RH GIVING 38RH.
  21384. 089000    IF FLAGG1 = 1
  21385. 089100        MOVE 36RH TO 36-44RX
  21386. 089200        MOVE 37RH TO 37-45RX
  21387. 089300        MOVE 38RH TO 38-46RX
  21388. 089400        DIVIDE 38RHT INTO 38RH GIVING PW1 ROUNDED
  21389. 089500        MOVE PW1X TO PERCENTS
  21390. 089600        MOVE HD4RX TO PRINT-REC
  21391. 089700        WRITE PRINT-REC
  21392. 089800     ELSE
  21393. 089900        MOVE 36RH TO 36-44R
  21394. 090000        MOVE 37RH TO 37-45R
  21395. 090100        MOVE 38RH TO 38-46R
  21396. 090200        MOVE HD4R TO PRINT-REC
  21397. 090300        WRITE PRINT-REC.
  21398. 090400    ADD 1 TO LINECT.
  21399. 090500    MOVE 35-43R TO 35-43RH.
  21400. 090600    IF KEYR1 = 1
  21401. 090700        MOVE 35-43R TO 35R2
  21402. 090800        MOVE 35R TO HD4-NAME.
  21403. 090900    IF (KEYR1 = 2) AND (39R = "E")
  21404. 091000        MOVE "EXCELLENT " TO HD4-NAMEX
  21405. 091100    ELSE IF (KEYR1 = 2) AND (39R = "G")
  21406. 091200        MOVE "GOOD      " TO HD4-NAMEX
  21407. 091300    ELSE IF (KEYR1 = 2) AND (39R = "F")
  21408. 091400        MOVE "FAIR      " TO HD4-NAMEX
  21409. 091500    ELSE IF (KEYR1 = 2) AND (39R = "P")
  21410. 091600        MOVE "POOR      " TO HD4-NAMEX
  21411. 091700    ELSE IF (KEYR1 = 2) AND (39R = "C")
  21412. 091800        MOVE "CROPLAND  " TO HD4-NAMEX
  21413. 091900    ELSE IF (KEYR1 = 2) AND (39R = "U")
  21414. 092000        MOVE "UNSUITABLE" TO HD4-NAMEX.
  21415. 092100    IF KEYR1 = 3
  21416. 092200        MOVE 35-43R TO 43R2
  21417. 092300        MOVE 43R TO HD4-NAME.
  21418. 092400    MOVE 36R TO 36RH.
  21419. 092500    MOVE 37R TO 37RH.
  21420. 092600    ADD 36R TO 36RHT.
  21421. 092700    ADD 37R TO 37RHT.
  21422. 092800 620-SP-EXIT.  EXIT.
  21423. 092900 700-HD-CKR.
  21424. 093000    IF KEYR1 = 1
  21425. 093100        MOVE " RESOURCE ACREAGE INFORMATION" TO HD5-NAME
  21426. 093200        MOVE KEYR1 TO KEYR1H
  21427. 093300        MOVE 35-43R TO 35-43RH, 35R2
  21428. 093400        MOVE 35R TO HD4-NAME
  21429. 093500        PERFORM 620-SUM-PROCESS THRU 620-SP-EXIT
  21430. 093600        PERFORM 810-OFLO-HD3 THRU 810-EXIT
  21431. 093700        GO TO 700-EXIT.
  21432. 093800    IF KEYR1 = 2
  21433. 093900        MOVE KEYR1 TO KEYR1H
  21434. 094000       PERFORM 820-CK-OFLO THRU 820-EXIT
  21435. 094100     ADD 36RHT, 37RHT GIVING 38RHT
  21436. 094200     MOVE 36RHT TO 36-44RT
  21437. 094300     MOVE 37RHT TO 37-45RT
  21438. 094400     MOVE 38RHT TO 38-46RT
  21439. 094500     MOVE ZEROS TO 36RHT, 37RHT
  21440. 094600        PERFORM 620-SUM-PROCESS THRU 620-SP-EXIT
  21441. 094700     MOVE HD5R TO PRINT-REC
  21442. 094800     WRITE PRINT-REC AFTER ADVANCING 3 LINES
  21443. 094900        MOVE 1 TO FLAGG1
  21444. 095000        MOVE "RANGE CONDITION SUMMARY" TO HD1-NAME, HD1RX-NAME
  21445. 095100        MOVE "CONDITION CLASS" TO HD3-NAME
  21446. 095200        PERFORM 810-OFLO-HD3 THRU 810-EXIT
  21447. 095300        GO TO 700-EXIT.
  21448. 095400    IF KEYR1 = 3
  21449. 095500        MOVE KEYR1 TO KEYR1H
  21450. 095600      PERFORM 820-CK-OFLO THRU 820-EXIT
  21451. 095700     ADD 36RHT, 37RHT GIVING 38RHT
  21452. 095800     MOVE 36RHT TO 36-44RT
  21453. 095900     MOVE 37RHT TO 37-45RT
  21454. 096000     MOVE 38RHT TO 38-46RT
  21455. 096100     MOVE ZEROS TO 36RHT, 37RHT
  21456. 096200        PERFORM 620-SUM-PROCESS THRU 620-SP-EXIT
  21457. 096300     MOVE HD5R TO PRINT-REC
  21458. 096400     WRITE PRINT-REC AFTER ADVANCING 3 LINES
  21459. 096500     MOVE 0 TO FLAGG1
  21460. 096600        MOVE "  SOIL SERIES SUMMARY  " TO HD1-NAME, HD1RX-NAME
  21461. 096700        MOVE "  SOIL SERIES  " TO HD3-NAME
  21462. 096800        PERFORM 810-OFLO-HD3 THRU 810-EXIT
  21463. 096900        GO TO 700-EXIT.
  21464. 097000 700-EXIT.  EXIT.
  21465. 097100 800-OFLO-HD2.
  21466. 097200    ADD 1 TO PAGECT.
  21467. 097300    MOVE PAGECT TO PG-NOX.
  21468. 097400    MOVE SPACES TO PRINT-REC.
  21469. 097500    WRITE PRINT-REC AFTER ADVANCING PAGE.
  21470. 097600    MOVE HD1RX TO PRINT-REC.
  21471. 097700    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21472. 097800    MOVE HD2R TO PRINT-REC.
  21473. 097900    WRITE PRINT-REC AFTER ADVANCING 3 LINES.
  21474. 098000    MOVE HD3R TO PRINT-REC.
  21475. 098100    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21476. 098200    MOVE SPACES TO PRINT-REC  WRITE PRINT-REC.
  21477. 098300    MOVE 9 TO LINECT.
  21478. 098400 800-EXIT.  EXIT.
  21479. 098500 810-OFLO-HD3.
  21480. 098600    ADD 1 TO PAGECT.
  21481. 098700    MOVE PAGECT TO HDR-PG.
  21482. 098800    MOVE SPACES TO PRINT-REC.
  21483. 098900    WRITE PRINT-REC AFTER ADVANCING PAGE.
  21484. 099000    MOVE HD1 TO PRINT-REC.
  21485. 099100    WRITE PRINT-REC.
  21486. 099200    MOVE HD3 TO PRINT-REC.
  21487. 099300    WRITE PRINT-REC.
  21488. 099400    MOVE HD4 TO PRINT-REC.
  21489. 099500    WRITE PRINT-REC.
  21490. 099600    MOVE HD5 TO PRINT-REC.
  21491. 099700    WRITE PRINT-REC.
  21492. 099800    MOVE HD1R TO PRINT-REC.
  21493. 099900    WRITE PRINT-REC AFTER ADVANCING 3 LINES.
  21494. 100000    MOVE HD2R TO PRINT-REC.
  21495. 100100    WRITE PRINT-REC AFTER ADVANCING 3 LINES.
  21496. 100200    MOVE HD3R TO PRINT-REC.
  21497. 100300    WRITE PRINT-REC AFTER ADVANCING 2 LINES.
  21498. 100400    MOVE SPACES TO PRINT-REC.
  21499. 100500    WRITE PRINT-REC.
  21500. 100600    MOVE 15 TO LINECT.
  21501. 100700 810-EXIT.  EXIT.
  21502. 100800 820-CK-OFLO.
  21503. 100900     IF LINECT > 53 PERFORM 800-OFLO-HD2 THRU 800-EXIT.
  21504. 101000 820-EXIT.  EXIT.
  21505. 101100 900-CLOSE.
  21506. 101200    IF LINECT > 53 PERFORM 800-OFLO-HD2 THRU 800-EXIT.
  21507. 101300    ADD 36RH, 37RH GIVING 38RH.
  21508. 101400    MOVE 36RH TO 36-44R.
  21509. 101500    MOVE 37RH TO 37-45R.
  21510. 101600    MOVE 38RH TO 38-46R.
  21511. 101700    MOVE HD4R TO PRINT-REC.
  21512. 101800    WRITE PRINT-REC.
  21513. 101900     IF LINECT > 53 PERFORM 800-OFLO-HD2 THRU 800-EXIT.
  21514. 102000     ADD 36RHT, 37RHT GIVING 38RHT.
  21515. 102100     MOVE 36RHT TO 36-44RT.
  21516. 102200     MOVE 37RHT TO 37-45RT.
  21517. 102300     MOVE 38RHT TO 38-46RT.
  21518. 102400     MOVE HD5R TO PRINT-REC.
  21519. 102500     WRITE PRINT-REC AFTER ADVANCING 3 LINES.
  21520. 102600     DISPLAY  "PAGES PRINTED " PAGECT.
  21521. 102700    CLOSE PRINT-FILE.
  21522. 000000*-----------------------------------------------------------------
  21523. 000100 IDENTIFICATION DIVISION.
  21524. 000200 PROGRAM-ID. ES520P.
  21525. 000300*        ALLOTMENT LEVEL STRATIFICATION SUMMARY (P2 LIST)
  21526. 000400*
  21527. 000500 AUTHOR. M.QUANDT.
  21528. 000700 ENVIRONMENT DIVISION.
  21529. 000800 CONFIGURATION SECTION.
  21530. 000900 SOURCE-COMPUTER. LEVEL-66-ASCII.
  21531. 001000 OBJECT-COMPUTER. LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
  21532. 001100 INPUT-OUTPUT SECTION.
  21533. 001200 FILE-CONTROL.
  21534. 001300     SELECT INPUT-FILE ASSIGN TO I1
  21535. 001400         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  21536. 001500     SELECT PRINT-OUT ASSIGN TO P1
  21537. 001600         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  21538. 001700     SELECT SWA-FILE ASSIGN TO D1
  21539. 001800         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  21540. 001900 DATA DIVISION.
  21541. 002000 SUB-SCHEMA SECTION.
  21542. 002100 DB  CODVAL2 WITHIN BLMDIC.
  21543. 002200 FILE SECTION.
  21544. 002300 FD  INPUT-FILE
  21545. 002400     CODE-SET IS GBCD
  21546. 002500     LABEL RECORDS ARE STANDARD.
  21547. 002600 01  IN-RECORD.
  21548. 002700     05  IN-REC-TYP                        PIC X(2).
  21549. 002800     05  IN-FMT-NUM                        PIC X.
  21550. 002900     05  IN-FORMAT-CD                      PIC X.
  21551. 003000     05  IN-BLM-ADM-U                      PIC X(8).
  21552. 003100     05  IN-CLMTC-ADJ-FCTR                 PIC 99V999.
  21553. 003200     05  IN-DATA-DATE                      PIC X(6).
  21554. 003300     05  IN-ACTION-CD                      PIC X.
  21555. 003400     05  IN-LIN-NUM                        PIC X(4).
  21556. 003500     05  IN-SWA                            PIC X(4).
  21557. 003600     05  IN-TRN-NUM                        PIC XX.
  21558. 003700     05  IN-SWA-PCT                        PIC 999.
  21559. 003800     05  IN-RNG-SITE-ID                    PIC X(11).
  21560. 003900     05  IN-STRATUM-NUM                    PIC X(4).
  21561. 004000     05  IN-ALLOT-NUM                      PIC X(4).
  21562. 004100     05  IN-PASTURE-NUM                    PIC XX.
  21563. 004200     05  IN-VEG-SUB-TYP                    PIC X(4).
  21564. 004300     05  IN-RNG-ECOL-COND-CLS              PIC X.
  21565. 004400     05  IN-PCT-SLP                        PIC XXX.
  21566. 004500     05  IN-ASPT                           PIC XX.
  21567. 004600     05  IN-L-FORM                         PIC XXX.
  21568. 004700     05  IN-SOIL-PHAS                      PIC X(5).
  21569. 004800     05  FILLER                            PIC XX.
  21570. 004900 FD  PRINT-OUT
  21571. 005000     CODE-SET IS GBCD
  21572. 005100     LABEL RECORDS ARE STANDARD.
  21573. 005200 01  PRINT-LINE  PIC X(132).
  21574. 005300 FD  SWA-FILE
  21575. 005400     CODE-SET IS GBCD
  21576. 005500     LABEL RECORDS ARE STANDARD
  21577. 005600     DATA RECORD IS SWA-REC.
  21578. 005700 01  SWA-REC.
  21579. 005800     05  OT-ST-DIST-RA-PLU                 PIC X(8).
  21580. 005900     05  OT-SWA                            PIC X(4).
  21581. 006000     05  OT-TRANSECT                       PIC 99.
  21582. 006100     05  OT-RANGE-SITE                     PIC X(11).
  21583. 006200     05  OT-STRATUM                        PIC 9(4).
  21584. 006300     05  OT-SWA-PERCENT                    PIC 9(3).
  21585. 006400     05  OT-ALLOTMENT                      PIC 9(4).
  21586. 006500     05  OT-PASTURE                        PIC 99.
  21587. 006600     05  OT-COMPARISON-AREA                PIC X.
  21588. 006700     05  OT-CLIMATIC-ADJ-FCTR              PIC 99V999.
  21589. 006800     05  OT-COND-CLS                       PIC X.
  21590. 006900     05  SPACE-FILL                        PIC X(3).
  21591. 007000 WORKING-STORAGE SECTION.
  21592. 007100 77  TRAN-INDX  PIC 999  VALUE ZERO.
  21593. 007200 77  TRANS-CNT  PIC 999  VALUE ZERO.
  21594. 007300 77  PERCENT-ACCUL                         PIC 999 VALUE ZEROS.
  21595. 007400 77  NEW-SKEY                              PIC X(8).
  21596. 007500 77  OLD-SKEY                              PIC X(8).
  21597. 007600 77  PG-CNT  PIC 9(5) VALUE ZEROS.
  21598. 007700 77  WORK-SPACES  PIC X(132) VALUE SPACES.
  21599. 007800 77  WORK-PRINT                            PIC X(132).
  21600. 007900 77  LINE-COUNT PIC 99 VALUE ZEROS.
  21601. 008000 77  WORK-PASTURE                          PIC XX.
  21602. 008100 77  READ-COUNT  PIC 9(7)  VALUE ZERO.
  21603. 008200 77  READ-COUNT-VB  PIC 9(7)  VALUE ZERO.
  21604. 008300 77  WRITE-COUNT  PIC 9(7)  VALUE ZERO.
  21605. 008400 77  NEW-ALLOT                             PIC X(4).
  21606. 008500 77  OLD-ALLOT                             PIC X(4).
  21607. 008600 77  NEW-PASTURE                           PIC XX.
  21608. 008700 77  OLD-PASTURE                           PIC XX.
  21609. 008800 77  NEW-SWA PIC X(4).
  21610. 008900 77  OLD-SWA PIC X(4).
  21611. 009000 77  NEW-STRA                              PIC X(4).
  21612. 009100 77  OLD-STRA                              PIC X(4).
  21613. 009200 01  SAVE-TRANSECT-TABLE.
  21614. 009300     05  SAVE-TRANSECT  PIC 99  OCCURS 100 TIMES.
  21615. 009400 01  ZERO-CONDITION PIC 9  VALUE IS ZERO.
  21616. 009500     88  ZERO-TRANSECT  VALUE IS 1.
  21617. 009600 01  SAVED-DATA.
  21618. 009700     05  FILLER  PIC X(13) VALUE SPACES.
  21619. 009800     05  SAVE-ALLOT                        PIC X(4).
  21620. 009900     05  FILLER  PIC X(17) VALUE SPACES.
  21621. 010000     05  SAVE-PASTURE                      PIC XX.
  21622. 010100     05  FILLER  PIC X(16) VALUE SPACES.
  21623. 010200     05  SAVE-SWA                          PIC X(4).
  21624. 010300 01  HOLD-AREA.
  21625. 010400     03  ADST-DIST-RA-PLU-CDS-H.
  21626. 010500         05  ADST-CD-H  PIC XX.
  21627. 010600         05  DIST-CD-H  PIC XX.
  21628. 010700         05  RA-CD-H  PIC XX.
  21629. 010800         05  PLU-CD-H  PIC XX.
  21630. 010900     03  DE-CD-EXPLN-8827-DECE-H.
  21631. 011000         05  DIST-NAM-H  PIC X(12).
  21632. 011100         05  RA-NAM-H  PIC X(13).
  21633. 011200         05  PLU-NAM-H  PIC X(15).
  21634. 011300     03  DE-CD-NAM-8823-DEC-H.
  21635. 011400         05  ST-NAM-H  PIC X(10).
  21636. 011500         05  FILLER  PIC X(14).
  21637. 011600 01  WS-IN-RECORD.
  21638. 011700     05  WS-REC-TYP                        PIC X(2).
  21639. 011800     05  WS-FMT-NUM                        PIC X.
  21640. 011900     05  WS-FORMAT-CD                      PIC X.
  21641. 012000     05  WS-BLM-ADM-U                      PIC X(8).
  21642. 012100     05  WS-CLMTC-ADJ-FCTR                 PIC 99V999.
  21643. 012200     05  WS-DATA-DATE                      PIC X(6).
  21644. 012300     05  WS-ACTION-CD                      PIC X.
  21645. 012400     05  WS-LIN-NUM                        PIC X(4).
  21646. 012500     05  WS-SWA                            PIC X(4).
  21647. 012600     05  WS-TRN-NUM                        PIC XX.
  21648. 012700     05  WS-SWA-PCT                        PIC 999.
  21649. 012800     05  WS-RNG-SITE-ID                    PIC X(11).
  21650. 012900     05  WS-STRATUM-NUM                    PIC X(4).
  21651. 013000     05  WS-ALLOT-NUM                      PIC X(4).
  21652. 013100     05  WS-PASTURE-NUM                    PIC XX.
  21653. 013200     05  WS-VEG-SUB-TYP                    PIC X(4).
  21654. 013300     05  WS-RNG-ECOL-COND-CLS              PIC X.
  21655. 013400     05  WS-PCT-SLP                        PIC XXX.
  21656. 013500     05  WS-ASPT                           PIC XX.
  21657. 013600     05  WS-L-FORM                         PIC XXX.
  21658. 013700     05  WS-SOIL-PHAS                      PIC X(5).
  21659. 013800     05  FILLER                            PIC XX.
  21660. 013900 01  PAG-HDR-1.
  21661. 014000     03  FILLER        PIC X(13) VALUE "REPORT DATE: ".
  21662. 014100     03  HEADER-DATE.
  21663. 014200         05  MO-HDR    PIC 99.
  21664. 014300         05  FILLER    PIC X     VALUE "/".
  21665. 014400         05  DA-HDR    PIC 99.
  21666. 014500         05  FILLER    PIC X     VALUE "/".
  21667. 014600         05  YR-HDR    PIC 99.
  21668. 014700     03  FILLER        PIC X(28) VALUE SPACES.
  21669. 014800     03  FILLER        PIC X(23) VALUE "U.S.D.I. BUREAU OF LAND".
  21670. 014900     03  FILLER        PIC X(11) VALUE " MANAGEMENT".
  21671. 015000     03  FILLER        PIC X(22) VALUE SPACES.
  21672. 015100     03  FILLER        PIC X(15) VALUE "PCN: P020      ".
  21673. 015200     03  FILLER        PIC X(6) VALUE " PAGE ".
  21674. 015300     03  PAGE-NO       PIC ZZ,ZZ9.
  21675. 015400 01  PAG-HDR-3.
  21676. 015500     03  FILLER        PIC X(20) VALUE "    STATE           ".
  21677. 015600     03  STATE-NAME    PIC X(10).
  21678. 015700     03  FILLER        PIC X(24) VALUE SPACES.
  21679. 015800     03  FILLER        PIC X(21) VALUE "ECOLOGICAL SITE INVEN".
  21680. 015900     03  FILLER        PIC X(04) VALUE "TORY".
  21681. 016000     03  FILLER        PIC X(53) VALUE SPACES.
  21682. 016100 01  PAG-HDR-4.
  21683. 016200     03  FILLER        PIC X(20) VALUE "    DISTRICT        ".
  21684. 016300     03  DIST-NAME     PIC X(12).
  21685. 016400     03  FILLER        PIC X(100) VALUE SPACES.
  21686. 016500 01  PAG-HDR-5.
  21687. 016600     03  FILLER        PIC X(20) VALUE "    RESOURCE AREA   ".
  21688. 016700     03  RA-NAME       PIC X(13).
  21689. 016800     03  FILLER        PIC X(13) VALUE SPACES.
  21690. 016900     03  FILLER        PIC X(19) VALUE "ALLOTMENT LEVEL STR".
  21691. 017000     03  FILLER        PIC X(19) VALUE "ATIFICATION SUMMARY".
  21692. 017100     03  FILLER        PIC X(46) VALUE SPACES.
  21693. 017200 01  PAG-HDR-6.
  21694. 017300     03  FILLER        PIC X(20) VALUE "    PLANNING UNIT   ".
  21695. 017400     03  PU-NAME      PIC X(15).
  21696. 017500     03  FILLER        PIC X(97) VALUE SPACES.
  21697. 017600 01  COL-HDR-1.
  21698. 017700     03  FILLER        PIC X(11) VALUE SPACES.
  21699. 017800     03  FILLER        PIC X(9)  VALUE "ALLOTMENT".
  21700. 017900     03  FILLER        PIC X(12) VALUE SPACES.
  21701. 018000     03  FILLER        PIC X(7)  VALUE "PASTURE".
  21702. 018100     03  FILLER        PIC X(14) VALUE SPACES.
  21703. 018200     03  FILLER        PIC X(3)  VALUE "SWA".
  21704. 018300     03  FILLER        PIC X(16) VALUE SPACES.
  21705. 018400     03  FILLER        PIC X(7)  VALUE "STRATUM".
  21706. 018500     03  FILLER        PIC X(12) VALUE SPACES.
  21707. 018600     03  FILLER        PIC X(8)  VALUE "% OF SWA".
  21708. 018700     03  FILLER        PIC X(11) VALUE SPACES.
  21709. 018800     03  FILLER        PIC X(10) VALUE "RANGE SITE".
  21710. 018900     03  FILLER        PIC X(12) VALUE SPACES.
  21711. 019000 01  DATA-LINE-1.
  21712. 019100     03  FILLER        PIC X(13) VALUE SPACES.
  21713. 019200     03  ALLOT-P       PIC X(4).
  21714. 019300     03  FILLER        PIC X(17) VALUE SPACES.
  21715. 019400     03  PASTURE-P     PIC XX.
  21716. 019500     03  FILLER        PIC X(16) VALUE SPACES.
  21717. 019600     03  SWA-P         PIC X(4).
  21718. 019700     03  FILLER        PIC X(17) VALUE SPACES.
  21719. 019800     03  STRATUM-P     PIC 9(4).
  21720. 019900     03  FILLER        PIC X(16) VALUE SPACES.
  21721. 020000     03  PCT-SWA-P     PIC ZZ9.
  21722. 020100     03  FILLER        PIC X(14) VALUE SPACES.
  21723. 020200     03  RNG-SITE-P    PIC X(11).
  21724. 020300     03  FILLER        PIC X(11) VALUE SPACES.
  21725. 020400 01  DATA-LINE-2 REDEFINES DATA-LINE-1 PIC X(132).
  21726. 020500 01  DATE-TODAY.
  21727. 020600     05  THIS-YEAR                         PIC 99.
  21728. 020700     05  THIS-MONTH                        PIC 99.
  21729. 020800     05  THIS-DAY                          PIC 99.
  21730. 020900 01  EOF-CONDITION                         PIC 9.
  21731. 021000     88  FILE-END  VALUE IS 1.
  21732. 021100 PROCEDURE DIVISION.
  21733. 021200 10-HOUSEKEEPING.
  21734. 021300     PERFORM 200-HOUSEKEEP THRU 205-EXIT.
  21735. 021400 20-MAINLINE.
  21736. 021500     PERFORM 210-READ-INPUT.
  21737. 021600     IF FILE-END
  21738. 021700         PERFORM 900-WRAPUP
  21739. 021800         STOP RUN.
  21740. 021900     IF IN-REC-TYP NOT EQUAL "VB"
  21741. 022000         GO TO 20-MAINLINE.
  21742. 022100     ADD 1 TO READ-COUNT-VB.
  21743. 022200     IF IN-PASTURE-NUM EQUAL "00"
  21744. 022300         MOVE SPACES TO WORK-PASTURE
  21745. 022400     ELSE MOVE IN-PASTURE-NUM TO WORK-PASTURE.
  21746. 022500     PERFORM 240-SKEY-CHANGE.
  21747. 022600     PERFORM 220-ALLOT-CHANGE THRU 226-STRA-CHANGE.
  21748. 022700     IF NEW-SKEY NOT EQUAL OLD-SKEY
  21749. 022800         OR NEW-ALLOT NOT EQUAL OLD-ALLOT
  21750. 022900         PERFORM 700-SAVE-TO-LINE
  21751. 023000         PERFORM 500-MOVE-ALLOT THRU 520-MOVE-SWA
  21752. 023100         GO TO 30-BYPASS.
  21753. 023200     IF NEW-PASTURE NOT EQUAL OLD-PASTURE
  21754. 023300         PERFORM 700-SAVE-TO-LINE
  21755. 023400         PERFORM 510-MOVE-PASTURE THRU 520-MOVE-SWA
  21756. 023500         GO TO 30-BYPASS.
  21757. 023600     IF NEW-SWA NOT EQUAL OLD-SWA
  21758. 023700         PERFORM 700-SAVE-TO-LINE
  21759. 023800         PERFORM 520-MOVE-SWA
  21760. 023900         GO TO 30-BYPASS.
  21761. 024000     IF NEW-STRA NOT EQUAL OLD-STRA
  21762. 024100         PERFORM 700-SAVE-TO-LINE
  21763. 024200         GO TO 30-BYPASS.
  21764. 024300     GO TO 40-CALCULATE.
  21765. 024400 30-BYPASS.
  21766. 024500     IF LINE-COUNT GREATER 54
  21767. 024600         PERFORM 710-1ST-LINE-MOVE.
  21768. 024700     PERFORM 310-MOVE-TO-PRINT THRU 330-MOVE-WRITE-FILE.
  21769. 024800     IF NEW-SKEY NOT EQUAL OLD-SKEY
  21770. 024900         PERFORM 250-SKEY-TO-HDR THRU 260-TOP-PAGE.
  21771. 025000     PERFORM 230-INITIAL-ACCUL.
  21772. 025100     PERFORM 610-EXCHANGE.
  21773. 025200 40-CALCULATE.
  21774. 025300         PERFORM 300-PERCENT-ADD.
  21775. 025400     GO TO 20-MAINLINE.
  21776. 025500 200-HOUSEKEEP.
  21777. 025600     OPEN INPUT INPUT-FILE.
  21778. 025700     OPEN OUTPUT PRINT-OUT SWA-FILE.
  21779. 025800     READY DIC-DE.
  21780. 025900     MOVE SPACES TO PRINT-LINE.
  21781. 026000     MOVE ZERO TO EOF-CONDITION.
  21782. 026100     INITIALIZE SWA-REC.
  21783. 026200     ACCEPT DATE-TODAY FROM DATE.
  21784. 026300     MOVE THIS-DAY TO DA-HDR.
  21785. 026400     MOVE THIS-MONTH TO MO-HDR.
  21786. 026500     MOVE THIS-YEAR TO YR-HDR.
  21787. 026600 201-READ-LOOP.
  21788. 026700     PERFORM 210-READ-INPUT.
  21789. 026800     IF FILE-END
  21790. 026900         DISPLAY "NO RECORD IN INPUT FILE"
  21791. 027000         PERFORM 900-WRAPUP
  21792. 027100         STOP RUN.
  21793. 027200     IF IN-REC-TYP NOT EQUAL "VB"
  21794. 027300         GO TO 201-READ-LOOP.
  21795. 027400     ADD 1 TO READ-COUNT-VB.
  21796. 027500     IF IN-PASTURE-NUM EQUAL "00"
  21797. 027600         MOVE SPACES TO WORK-PASTURE
  21798. 027700     ELSE MOVE IN-PASTURE-NUM TO WORK-PASTURE.
  21799. 027800     PERFORM 610-EXCHANGE.
  21800. 027900     PERFORM 250-SKEY-TO-HDR.
  21801. 028000     PERFORM 260-TOP-PAGE.
  21802. 028100     MOVE SPACES TO SAVED-DATA.
  21803. 028200     PERFORM 500-MOVE-ALLOT THRU 520-MOVE-SWA.
  21804. 028300     MOVE IN-ALLOT-NUM TO NEW-ALLOT.
  21805. 028400     MOVE IN-PASTURE-NUM TO NEW-PASTURE.
  21806. 028500     MOVE IN-SWA TO NEW-SWA.
  21807. 028600     MOVE IN-STRATUM-NUM TO NEW-STRA.
  21808. 028700     MOVE IN-BLM-ADM-U TO NEW-SKEY.
  21809. 028800     PERFORM 300-PERCENT-ADD.
  21810. 028900 205-EXIT.
  21811. 029000     EXIT.
  21812. 029100 210-READ-INPUT.
  21813. 029200     READ INPUT-FILE
  21814. 029300         AT END MOVE 1 TO EOF-CONDITION
  21815. 029400         SUBTRACT 1 FROM READ-COUNT.
  21816. 029500     ADD 1 TO READ-COUNT.
  21817. 029600 220-ALLOT-CHANGE.
  21818. 029700     MOVE NEW-ALLOT TO OLD-ALLOT.
  21819. 029800     MOVE IN-ALLOT-NUM TO NEW-ALLOT.
  21820. 029900 222-PASTURE-CHANGE.
  21821. 030000     MOVE NEW-PASTURE TO OLD-PASTURE.
  21822. 030100     MOVE IN-PASTURE-NUM TO NEW-PASTURE.
  21823. 030200 224-SWA-CHANGE.
  21824. 030300     MOVE NEW-SWA TO OLD-SWA.
  21825. 030400     MOVE IN-SWA TO NEW-SWA.
  21826. 030500 226-STRA-CHANGE.
  21827. 030600     MOVE NEW-STRA TO OLD-STRA.
  21828. 030700     MOVE IN-STRATUM-NUM TO NEW-STRA.
  21829. 030800 230-INITIAL-ACCUL.
  21830. 030900     MOVE ZEROS TO PERCENT-ACCUL.
  21831. 031000 240-SKEY-CHANGE.
  21832. 031100     MOVE NEW-SKEY TO OLD-SKEY.
  21833. 031200     MOVE IN-BLM-ADM-U TO NEW-SKEY.
  21834. 031300 250-SKEY-TO-HDR.
  21835. 031400     MOVE 0003 TO DE-NO-8801-DEC.
  21836. 031500     MOVE IN-BLM-ADM-U TO DE-CD-8822-DEC.
  21837. 031600     FIND ANY CODE-DEC.
  21838. 031700     IF DB-STATUS NOT = ZERO
  21839. 031800         DISPLAY "BAD STATE CODE"  CALL "ABOR".
  21840. 031900     GET CODE-DEC.
  21841. 032000     MOVE DE-CD-NAM-8823-DEC TO DE-CD-NAM-8823-DEC-H.
  21842. 032100     FIND NEXT CODE-EXPL-DECE WITHIN DEC-DECE.
  21843. 032200     IF DB-STATUS NOT = ZERO
  21844. 032300         DISPLAY "ST-DIST-RA-PLU IS " IN-BLM-ADM-U
  21845. 032400         DISPLAY "BAD DIST, RA, PLU CODES"  CALL "ABOR".
  21846. 032500     GET CODE-EXPL-DECE.
  21847. 032600     MOVE DE-CD-EXPLN-8827-DECE TO DE-CD-EXPLN-8827-DECE-H.
  21848. 032700     MOVE ST-NAM-H TO STATE-NAME.
  21849. 032800     MOVE RA-NAM-H TO RA-NAME.
  21850. 032900     MOVE DIST-NAM-H TO DIST-NAME.
  21851. 033000     MOVE PLU-NAM-H TO PU-NAME.
  21852. 033100 260-TOP-PAGE.
  21853. 033200     ADD 1 TO PG-CNT.
  21854. 033300     MOVE PG-CNT TO PAGE-NO.
  21855. 033400     IF PG-CNT = 1
  21856. 033500         DISPLAY PAG-HDR-1
  21857. 033600         DISPLAY PAG-HDR-3
  21858. 033700         DISPLAY PAG-HDR-4
  21859. 033800         DISPLAY PAG-HDR-5
  21860. 033900         DISPLAY PAG-HDR-6
  21861. 034000         DISPLAY SPACES
  21862. 034100         DISPLAY COL-HDR-1
  21863. 034200         DISPLAY SPACES.
  21864. 034300     WRITE PRINT-LINE FROM PAG-HDR-1
  21865. 034400         AFTER ADVANCING PAGE.
  21866. 034500     WRITE PRINT-LINE FROM PAG-HDR-3
  21867. 034600         AFTER ADVANCING 1 LINE.
  21868. 034700     WRITE PRINT-LINE FROM PAG-HDR-4
  21869. 034800         AFTER ADVANCING 1 LINE.
  21870. 034900     WRITE PRINT-LINE FROM PAG-HDR-5
  21871. 035000         AFTER ADVANCING 1 LINE.
  21872. 035100     WRITE PRINT-LINE FROM PAG-HDR-6
  21873. 035200         AFTER ADVANCING 1 LINE.
  21874. 035300     WRITE PRINT-LINE FROM COL-HDR-1
  21875. 035400         AFTER ADVANCING 2 LINES.
  21876. 035500     WRITE PRINT-LINE FROM WORK-SPACES
  21877. 035600         AFTER ADVANCING 2 LINE.
  21878. 035700     MOVE 9 TO LINE-COUNT.
  21879. 035800 300-PERCENT-ADD.
  21880. 035900     IF IN-TRN-NUM EQUAL ZERO
  21881. 036000         MOVE 1 TO ZERO-CONDITION
  21882. 036100     ELSE ADD 1 TO TRAN-INDX
  21883. 036200         IF TRAN-INDX GREATER 100
  21884. 036300             DISPLAY "MORE THAN 100 TRANSECTS PER STRATUM"
  21885. 036400             STOP RUN
  21886. 036500         ELSE
  21887. 036600             MOVE IN-TRN-NUM TO SAVE-TRANSECT (TRAN-INDX).
  21888. 036700     ADD IN-SWA-PCT TO PERCENT-ACCUL.
  21889. 036800 310-MOVE-TO-PRINT.
  21890. 036900     MOVE PERCENT-ACCUL TO PCT-SWA-P.
  21891. 037000     MOVE WS-STRATUM-NUM TO STRATUM-P.
  21892. 037100     MOVE WS-RNG-SITE-ID TO RNG-SITE-P.
  21893. 037200     MOVE DATA-LINE-1 TO WORK-PRINT.
  21894. 037300 320-WRITE-PRINT.
  21895. 037400     IF LINE-COUNT GREATER 54
  21896. 037500         PERFORM 260-TOP-PAGE.
  21897. 037600     IF PG-CNT = 1
  21898. 037700         DISPLAY WORK-PRINT.
  21899. 037800     WRITE PRINT-LINE FROM WORK-PRINT
  21900. 037900         AFTER ADVANCING 1 LINE.
  21901. 038000     ADD 1 TO LINE-COUNT.
  21902. 038100 330-MOVE-WRITE-FILE.
  21903. 038200     MOVE PERCENT-ACCUL TO OT-SWA-PERCENT.
  21904. 038300     MOVE WS-BLM-ADM-U TO OT-ST-DIST-RA-PLU.
  21905. 038400     MOVE WS-SWA TO OT-SWA.
  21906. 038500     MOVE WS-RNG-SITE-ID TO OT-RANGE-SITE.
  21907. 038600     MOVE WS-STRATUM-NUM TO OT-STRATUM.
  21908. 038700     MOVE WS-RNG-ECOL-COND-CLS TO OT-COND-CLS.
  21909. 038800     MOVE WS-ALLOT-NUM TO OT-ALLOTMENT.
  21910. 038900     IF WS-PASTURE-NUM EQUAL SPACES
  21911. 039000         MOVE ZEROS TO OT-PASTURE
  21912. 039100     ELSE MOVE WS-PASTURE-NUM TO OT-PASTURE.
  21913. 039200     MOVE WS-CLMTC-ADJ-FCTR TO OT-CLIMATIC-ADJ-FCTR.
  21914. 039300     PERFORM 340-MOVE-TRANSECTS THRU 349-EXIT.
  21915. 039400     MOVE ZERO TO TRAN-INDX.
  21916. 039500     MOVE ZERO TO TRANS-CNT.
  21917. 039600     MOVE ZERO TO ZERO-CONDITION.
  21918. 039700 340-MOVE-TRANSECTS.
  21919. 039800     IF ZERO-TRANSECT
  21920. 039900         MOVE ZEROS TO OT-TRANSECT
  21921. 040000         PERFORM 350-WRITE-SWA-REC.
  21922. 040100 345-TRANS-LOOP.
  21923. 040200     ADD 1 TO TRANS-CNT.
  21924. 040300     IF TRANS-CNT GREATER TRAN-INDX
  21925. 040400         GO TO 349-EXIT.
  21926. 040500     MOVE SAVE-TRANSECT (TRANS-CNT) TO OT-TRANSECT
  21927. 040600     PERFORM 350-WRITE-SWA-REC.
  21928. 040700     GO TO 345-TRANS-LOOP.
  21929. 040800 349-EXIT.
  21930. 040900     EXIT.
  21931. 041000 350-WRITE-SWA-REC.
  21932. 041100     WRITE SWA-REC.
  21933. 041200     ADD 1 TO WRITE-COUNT.
  21934. 041300 500-MOVE-ALLOT.
  21935. 041400     MOVE IN-ALLOT-NUM TO SAVE-ALLOT.
  21936. 041500 510-MOVE-PASTURE.
  21937. 041600     MOVE WORK-PASTURE TO SAVE-PASTURE.
  21938. 041700 520-MOVE-SWA.
  21939. 041800     MOVE IN-SWA TO SAVE-SWA.
  21940. 041900 610-EXCHANGE.
  21941. 042000     MOVE IN-RECORD TO WS-IN-RECORD.
  21942. 042100     MOVE WORK-PASTURE TO WS-PASTURE-NUM.
  21943. 042200 700-SAVE-TO-LINE.
  21944. 042300     MOVE SAVED-DATA TO DATA-LINE-2.
  21945. 042400     MOVE SPACES TO SAVED-DATA.
  21946. 042500 710-1ST-LINE-MOVE.
  21947. 042600     MOVE WS-ALLOT-NUM TO ALLOT-P.
  21948. 042700     MOVE WS-PASTURE-NUM TO PASTURE-P.
  21949. 042800     MOVE WS-SWA TO SWA-P.
  21950. 042900 900-WRAPUP.
  21951. 043000     MOVE SAVED-DATA TO DATA-LINE-2.
  21952. 043100     IF LINE-COUNT GREATER 54
  21953. 043200         MOVE WS-ALLOT-NUM TO ALLOT-P
  21954. 043300         MOVE WS-PASTURE-NUM TO PASTURE-P
  21955. 043400         MOVE WS-SWA TO SWA-P.
  21956. 043500     PERFORM 310-MOVE-TO-PRINT THRU 330-MOVE-WRITE-FILE.
  21957. 043600     FINISH DIC-DE.
  21958. 043700     DISPLAY READ-COUNT " RECORDS READ".
  21959. 043800     DISPLAY READ-COUNT-VB " VB RECORDS READ".
  21960. 043900     DISPLAY WRITE-COUNT " RECORDS WRITTEN".
  21961. 044000     CLOSE INPUT-FILE PRINT-OUT SWA-FILE.
  21962. 000000*-----------------------------------------------------------------
  21963. 000100 IDENTIFICATION DIVISION.
  21964. 000200 PROGRAM-ID. ES524Z.
  21965. 000300*        STOCKING RATE FILE BUILD.
  21966. 000400*
  21967. 000500 AUTHOR. RON BAKER.
  21968. 000600 DATE-WRITTEN.  NOV 81.
  21969. 000700 DATE-COMPILED.
  21970. 000800 ENVIRONMENT DIVISION.
  21971. 000900 CONFIGURATION SECTION.
  21972. 001000 SOURCE-COMPUTER.  LEVEL-66-ASCII.
  21973. 001100 OBJECT-COMPUTER.  LEVEL-66-ASCII, SEQUENCE IS EBCDIC.
  21974. 001200 INPUT-OUTPUT SECTION.
  21975. 001300 FILE-CONTROL.
  21976. 001400     SELECT ACRE-FILE ASSIGN TO I1
  21977. 001500          ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  21978. 001600     SELECT STRATUM-FILE ASSIGN TO I2
  21979. 001700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  21980. 001800     SELECT VM-FILE ASSIGN TO I3
  21981. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  21982. 002000     SELECT ACRE-WORK-FILE ASSIGN TO W1
  21983. 002100         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  21984. 002200     SELECT STRATUM-WORK-FILE ASSIGN TO W2
  21985. 002300         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  21986. 002400     SELECT OWNER-WORK-FILE ASSIGN TO W3
  21987. 002500         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  21988. 002600     SELECT STOCKING-FILE ASSIGN TO D1
  21989. 002700         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  21990. 002800     SELECT SORT-FILE ASSIGN TO S1 S2 S3.
  21991. 002900     SELECT SORT-FILE-2 ASSIGN TO S1 S2 S3.
  21992. 003000     SELECT SORT-FILE-3 ASSIGN TO S1 S2 S3.
  21993. 003100     SELECT SORT-FILE-4 ASSIGN TO S1 S2 S3.
  21994. 003200 DATA DIVISION.
  21995. 003300 FILE SECTION.
  21996. 003400 FD  STOCKING-FILE
  21997. 003500      CODE-SET IS GBCD
  21998. 003600     LABEL RECORD IS STANDARD.
  21999. 003700 01  STOCKING-REC.
  22000. 003800     03  ADM-UNIT-D1.
  22001. 003900         05  ST-D1         PIC X(02).
  22002. 004000         05  DIS-D1        PIC X(02).
  22003. 004100         05  RA-D1         PIC X(02).
  22004. 004200         05  PLU-D1        PIC X(02).
  22005. 004300     03  ALLOT-D1.
  22006. 004400         05  ALLOT-NUM-D1      PIC X(04).
  22007. 004500         05  PAST-NUM-D1       PIC X(02).
  22008. 004600     03  STRATUM-D1        PIC X(04).
  22009. 004700     03  RNG-SITE-D1       PIC X(11).
  22010. 004800     03  SWA-D1            PIC X(04).
  22011. 004900     03  COND-CLS-D1       PIC X(01).
  22012. 005000     03  ACRES-SWA-TOT-D1  PIC 9(06).
  22013. 005100     03  ACRES-OWNER-STRATUM-TOT-D1  PIC 9(06).
  22014. 005200     03  ACRES-STRATUM-SUM-D1        PIC 9(06).
  22015. 005300     03  PCT-OWNER-SWA-D1    PIC 9(03)V99.
  22016. 005400     03  FILLER               PIC XX.
  22017. 005500     03  OWNER-D1           PIC X(04).
  22018. 005600     03  JURIS-D1           PIC X(04).
  22019. 005700     03  MGT-ADM-D1         PIC X(04).
  22020. 005800     03  LAND-TYP-D1        PIC X(04).
  22021. 005900     03  FILLER             PIC X(03).
  22022. 006000     03  STOCK-RATE-KEY-D1  PIC X.
  22023. 006100     03  STOCKING-RATE-GRP-D1.
  22024. 006200         05  STOCKING-RATE-D1   PIC X(05)  OCCURS 5 TIMES.
  22025. 006300     03  FILLER             PIC X(04).
  22026. 006400 FD  ACRE-FILE
  22027. 006500     CODE-SET IS GBCD
  22028. 006600     LABEL RECORDS ARE STANDARD.
  22029. 006700 01  ACRE-REC.
  22030. 006800     03  REC-I1.
  22031. 006900         05  REC-TYP-I1    PIC X(02).
  22032. 007000         05  FMT-NUM-I1    PIC X.
  22033. 007100         05  FMT-CD-I1     PIC X.
  22034. 007200     03  ADM-UNIT-I1.
  22035. 007300         05  ST-I1         PIC X(02).
  22036. 007400         05  DIS-I1        PIC X(02).
  22037. 007500         05  RA-I1         PIC X(02).
  22038. 007600         05  PLU-I1        PIC X(02).
  22039. 007700     03  ALLOT-I1.
  22040. 007800         05  ALLOT-NUM-I1  PIC X(04).
  22041. 007900         05  PAST-NUM-I1   PIC X(02).
  22042. 008000     03  DATE-I1           PIC X(06).
  22043. 008100     03  ACT-I1            PIC X(01).
  22044. 008200     03  MAP-SRC-I1        PIC X(04).
  22045. 008300     03  MTR-MER-CD-I1     PIC X(02).
  22046. 008400     03  LINE-I1           PIC X(04).
  22047. 008500     03  MTR-TWN-I1        PIC X(05).
  22048. 008600     03  MTR-RNG-I1        PIC X(05).
  22049. 008700     03  SEC-I1            PIC X(03).
  22050. 008800     03  SWA-I1            PIC X(04).
  22051. 008900     03  ALIQ-PART-I1      PIC X(16).
  22052. 009000     03  ACRES-I1          PIC 9(05).
  22053. 009100     03  OWNER-I1          PIC X(04).
  22054. 009200     03  JURIS-I1             PIC X(04).
  22055. 009300     03  MGT-ADM-I1           PIC X(04).
  22056. 009400     03  LAND-TYP-I1          PIC X(04).
  22057. 009500     03  FILLER               PIC X(01).
  22058. 009600 FD ACRE-WORK-FILE
  22059. 009700      CODE-SET IS GBCD
  22060. 009800     LABEL RECORD IS STANDARD.
  22061. 009900 01  ACRE-WORK-REC.
  22062. 010000     03  ADM-UNIT-W1.
  22063. 010100         05  ST-W1         PIC X(02).
  22064. 010200         05  DIS-W1        PIC X(02).
  22065. 010300         05  RA-W1         PIC X(02).
  22066. 010400         05  PLU-W1        PIC X(02).
  22067. 010500     03  ALLOT-W1.
  22068. 010600         05  ALLOT-NUM-W1      PIC X(04).
  22069. 010700         05  PAST-NUM-W1       PIC X(02).
  22070. 010800     03  SWA-W1            PIC X(04).
  22071. 010900     03  ACRES-SWA-TOT-W1  PIC 9(06).
  22072. 011000     03  ACRES-OWNER-TOT-W1  PIC 9(06).
  22073. 011100     03  PCT-OWNER-SWA-W1  PIC 9(03)V99.
  22074. 011200     03  FILLER            PIC XX.
  22075. 011300     03  OWNER-W1          PIC X(04).
  22076. 011400     03  JURIS-W1           PIC X(04).
  22077. 011500     03  MGT-ADM-W1         PIC X(04).
  22078. 011600     03  LAND-TYP-W1        PIC X(04).
  22079. 011700     03  FILLER             PIC X.
  22080. 011800 FD  OWNER-WORK-FILE
  22081. 011900      CODE-SET IS GBCD
  22082. 012000     LABEL RECORD IS STANDARD.
  22083. 012100 01  OWNER-WORK-REC.
  22084. 012200     03  ADM-UNIT-W3.
  22085. 012300         05  SD-W3.
  22086. 012400             07  ST-W3         PIC X(02).
  22087. 012500             07  DIS-W3        PIC X(02).
  22088. 012600         05  RA-W3         PIC X(02).
  22089. 012700         05  PLU-W3        PIC X(02).
  22090. 012800     03  ALLOT-W3.
  22091. 012900         05  ALLOT-NUM-W3      PIC X(04).
  22092. 013000         05  PAST-NUM-W3       PIC X(02).
  22093. 013100     03  STRATUM-W3        PIC X(04).
  22094. 013200     03  RNG-SITE-W3       PIC X(11).
  22095. 013300     03  SWA-W3            PIC X(04).
  22096. 013400     03  COND-CLS-W3       PIC X(01).
  22097. 013500     03  ACRES-SWA-TOT-W3  PIC 9(06).
  22098. 013600     03  ACRES-OWNER-STRATUM-TOT-W3  PIC 9(06).
  22099. 013700     03  ACRES-STRATUM-SUM-W3        PIC 9(06).
  22100. 013800     03  PCT-OWNER-SWA-W3            PIC 9(03)V99.
  22101. 013900     03  FILLER                      PIC XX.
  22102. 014000     03  OWNER-W3                    PIC X(04).
  22103. 014100     03  JURIS-W3           PIC X(04).
  22104. 014200     03  MGT-ADM-W3         PIC X(04).
  22105. 014300     03  LAND-TYP-W3        PIC X(04).
  22106. 014400     03  FILLER             PIC X(03).
  22107. 014500 FD STRATUM-FILE
  22108. 014600      CODE-SET IS GBCD
  22109. 014700     LABEL RECORD IS STANDARD.
  22110. 014800 01  STRATUM-REC.
  22111. 014900     03  ADM-UNIT-I2.
  22112. 015000         05  ST-I2          PIC X(02).
  22113. 015100         05  DIS-I2         PIC X(02).
  22114. 015200         05  RA-I2          PIC X(02).
  22115. 015300         05  PLU-I2         PIC X(02).
  22116. 015400     03  SWAT-I2.
  22117. 015500         05  SWA-I2         PIC X(4).
  22118. 015600         05  TRANS-I2       PIC 99.
  22119. 015700     03  RNG-SITE-I2        PIC X(11).
  22120. 015800     03  STRATUM-I2         PIC 9(4).
  22121. 015900     03  PCT-SWA-I2         PIC 9(03).
  22122. 016000     03  ALLOT-I2.
  22123. 016100         05  ALLOT-NUM-I2   PIC X(04).
  22124. 016200         05  PAST-NUM-I2    PIC X(02).
  22125. 016300     03  COMP-AREA-I2       PIC X.
  22126. 016400     03  CLIM-ADJ-FCTR-I2   PIC 99V999.
  22127. 016500     03  COND-CLS-I2        PIC X.
  22128. 016600     03  FILLER             PIC X(3).
  22129. 016700 FD VM-FILE
  22130. 016800      CODE-SET IS GBCD
  22131. 016900     LABEL RECORD IS STANDARD.
  22132. 017000 01  VM-REC.
  22133. 017100     03  REC-I3.
  22134. 017200         05  REC-TYP-I3    PIC X(02).
  22135. 017300         05  FMT-NUM-I3    PIC X.
  22136. 017400         05  FMT-CD-I3     PIC X.
  22137. 017500     03  ADM-UNIT-I3.
  22138. 017600         05  SD-I3.
  22139. 017700             07  ST-I3          PIC X(02).
  22140. 017800             07  DIS-I3         PIC X(02).
  22141. 017900     03  DATE-I3           PIC X(06).
  22142. 018000     03  ACT-I3            PIC X.
  22143. 018100     03  STOCK-RATE-KEY-I3 PIC 9.
  22144. 018200     03  RNG-SITE-I3       PIC X(11).
  22145. 018300     03  STOCKING-RATE-GRP-I3.
  22146. 018400         05  STOCKING-RATE-I3  PIC X(05)  OCCURS 5 TIMES.
  22147. 018500     03  FILLER            PIC X(32).
  22148. 018600 FD STRATUM-WORK-FILE
  22149. 018700      CODE-SET IS GBCD
  22150. 018800     LABEL RECORD IS STANDARD.
  22151. 018900 01  STRATUM-WORK-REC.
  22152. 019000     03  ADM-UNIT-W2.
  22153. 019100         05  ST-W2          PIC X(02).
  22154. 019200         05  DIS-W2         PIC X(02).
  22155. 019300         05  RA-W2          PIC X(02).
  22156. 019400         05  PLU-W2         PIC X(02).
  22157. 019500     03  SWAT-W2.
  22158. 019600         05  SWA-W2         PIC X(4).
  22159. 019700         05  TRANS-W2       PIC 99.
  22160. 019800     03  RNG-SITE-W2        PIC X(11).
  22161. 019900     03  STRATUM-W2         PIC 9(4).
  22162. 020000     03  PCT-SWA-TOT-W2     PIC 9(03).
  22163. 020100     03  ALLOT-W2.
  22164. 020200         05  ALLOT-NUM-W2   PIC X(04).
  22165. 020300         05  PAST-NUM-W2    PIC X(02).
  22166. 020400     03  COMP-AREA-I2       PIC X.
  22167. 020500     03  CLIM-ADJ-FCTR-I2   PIC 99V999.
  22168. 020600     03  COND-CLS-W2        PIC X.
  22169. 020700     03  FILLER             PIC X(03).
  22170. 020800 SD  SORT-FILE
  22171. 020900     DATA RECORD IS SORT-REC.
  22172. 021000 01  SORT-REC.
  22173. 021100     03  SORT-KEY-SK1.
  22174. 021200         05  ADM-UNIT-SK1  PIC X(08).
  22175. 021300         05  ALLOT-SK1.
  22176. 021400             07  ALLOT-NUM-SK1   PIC X(04).
  22177. 021500             07  PAST-NUM-SK1    PIC X(02).
  22178. 021600         05  SWA-SK1       PIC X(04).
  22179. 021700         05  KEY-SK1       PIC 9.
  22180. 021800         05  OWNER-SK1     PIC X(04).
  22181. 021900     03  DATA-SK1.
  22182. 022000         05  FILLER         PIC X(68).
  22183. 022100         05  ACRES-SK1      PIC 9(05).
  22184. 022200         05  FILLER         PIC X(17).
  22185. 022300 SD  SORT-FILE-2
  22186. 022400     DATA RECORD IS SORT-REC-2.
  22187. 022500 01  SORT-REC-2.
  22188. 022600     03  SORT-KEY-SK2.
  22189. 022700         05  ADM-UNIT-SK2  PIC X(08).
  22190. 022800         05  ALLOT-SK2.
  22191. 022900             07  ALLOT-NUM-SK2   PIC X(04).
  22192. 023000             07  PAST-NUM-SK2    PIC X(02).
  22193. 023100         05  STRATUM-SK2   PIC X(04).
  22194. 023200         05  SWAT-SK2       PIC X(06).
  22195. 023300     03  DATA-SK2         PIC X(48).
  22196. 023400 SD  SORT-FILE-3
  22197. 023500     DATA RECORD IS SORT-REC-3.
  22198. 023600 01  SORT-REC-3.
  22199. 023700     03  SORT-KEY-SK3.
  22200. 023800         05  SWA-CNTL-SK3.
  22201. 023900             07  ADM-UNIT-SK3  PIC X(08).
  22202. 024000             07  ALLOT-SK3.
  22203. 024100                 09  ALLOT-NUM-SK3   PIC X(04).
  22204. 024200                 09  PAST-NUM-SK3    PIC X(02).
  22205. 024300             07  SWA-SK3       PIC X(04).
  22206. 024400         05  STRATUM-SK3   PIC X(04).
  22207. 024500     03  DATA-SK3.
  22208. 024600         05  FILLER          PIC X(29).
  22209. 024700         05  PCT-SWA-TOT-SK3 PIC 9(03).
  22210. 024800         05  FILLER          PIC X(12).
  22211. 024900         05  COND-CLS-SK3    PIC X.
  22212. 025000         05  FILLER          PIC X(03).
  22213. 025100 SD  SORT-FILE-4
  22214. 025200     DATA RECORD IS SORT-REC-4.
  22215. 025300 01  SORT-REC-4.
  22216. 025400     03  SORT-KEY-SK4.
  22217. 025500         05  CNTL-SK4.
  22218. 025600             07  RNG-SITE-SK4  PIC X(11).
  22219. 025700             07  STRATUM-SK4   PIC X(04).
  22220. 025800             07  ALLOT-SK4.
  22221. 025900                 09  ALLOT-NUM-SK4   PIC X(04).
  22222. 026000                 09  PAST-NUM-SK4    PIC X(02).
  22223. 026100         05  KEY-SK4       PIC 9.
  22224. 026200     03  DATA-SK4.
  22225. 026300         05  FILLER                  PIC X(46).
  22226. 026400         05  ACRES-STRATUM-SUM-SK4   PIC 9(06).
  22227. 026500         05  FILLER                  PIC X(56).
  22228. 026600 WORKING-STORAGE SECTION.
  22229. 026700 77  PAGE-NO      COMP-4   PIC 9(6) VALUE 0.
  22230. 026800 77  TEST-CNT-1     PIC 9(8)  VALUE ZERO.
  22231. 026900 77  TEST-CNT-2     PIC 9(8)  VALUE ZERO.
  22232. 027000 77  CNTL-SK4-HLD          PIC X(21)  VALUE SPACE.
  22233. 027100 77  KEY-PREV              PIC 9  VALUE ZERO.
  22234. 027200 77  SK1-SW                PIC 9  VALUE ZERO.
  22235. 027300 77  SK2-SW                PIC 9  VALUE ZERO.
  22236. 027400 77  SK3-SW                PIC 9  VALUE ZERO.
  22237. 027500 77  END-SW                PIC 9  VALUE ZERO.
  22238. 027600 77  SUB                    PIC 99  VALUE ZERO.
  22239. 027700 77  OWNER-SW              PIC 9  VALUE ZERO.
  22240. 027800 77  SWA-SW                PIC 9  VALUE ZERO.
  22241. 027900 77  X          COMP-4   PIC 9 VALUE 0.
  22242. 028000 77  Y          COMP-4   PIC 9 VALUE 0.
  22243. 028100 77  ACRES-SWA-TOT-HLD     PIC 9(06)  VALUE ZERO.
  22244. 028200 77  ACRES-OWNER-TOT-HLD   PIC 9(08)  VALUE ZERO.
  22245. 028300 77  ACRES-STRATUM-SUM-HLD   PIC 9(06)  VALUE ZERO.
  22246. 028400 77  ACRES-OWNER-SWA-STRATUM-HLD   PIC 9(06)  VALUE ZERO.
  22247. 028500 01  CNTL-W3-HLD.
  22248. 028600     03  RNG-SITE-W3-HLD            PIC X(11).
  22249. 028700     03  STRATUM-W3-HLD             PIC X(04).
  22250. 028800     03  ALLOT-W3-HLD.
  22251. 028900         05  ALLOT-NUM-W3-HLD   PIC X(04).
  22252. 029000         05  PAST-NUM-W3-HLD    PIC X(02).
  22253. 029100 01  PCT-SWA-STRATUM-TOT-HLD PIC 9(03)V99  VALUE ZERO.
  22254. 029200 01  PCT-SWA-STRATUM-RD REDEFINES PCT-SWA-STRATUM-TOT-HLD
  22255. 029300                            PIC 9V9999.
  22256. 029400 01  PCT-SWA-OWNER-HLD PIC 9(03)V99  VALUE ZERO.
  22257. 029500 01  PCT-SWA-OWNER-RD REDEFINES PCT-SWA-OWNER-HLD
  22258. 029600                            PIC 9V9999.
  22259. 029700 01  PCT-SWA-OWNER-STRATUM-HLD PIC 9(03)V99  VALUE ZERO.
  22260. 029800 01  PCT-SWA-OWNER-STRATUM-RD REDEFINES PCT-SWA-OWNER-STRATUM-HLD
  22261. 029900                            PIC 9V9999.
  22262. 030000 01  ACRE-CNTL-HLD.
  22263. 030100     03  ADM-UNIT-ACRE-CNTL.
  22264. 030200         05  ST-ACRE-CNTL        PIC X(02).
  22265. 030300         05  DIS-ACRE-CNTL       PIC X(02).
  22266. 030400         05  RA-ACRE-CNTL        PIC X(02).
  22267. 030500         05  PLU-ACRE-CNTL       PIC X(02).
  22268. 030600     03  ALLOT-ACRE-CNTL.
  22269. 030700         05  ALLOT-NUM-ACRE-CNTL   PIC X(04).
  22270. 030800         05  PAST-NUM-ACRE-CNTL    PIC X(02).
  22271. 030900     03  SWA-ACRE-CNTL           PIC X(04).
  22272. 031000 01  STRATUM-CNTL-HLD.
  22273. 031100     03  SWA-CNTL-HLD.
  22274. 031200         05  ADM-UNIT-SWA-CNTL.
  22275. 031300             07  ST-SWA-CNTL        PIC X(02).
  22276. 031400             07  DIS-SWA-CNTL       PIC X(02).
  22277. 031500             07  RA-SWA-CNTL        PIC X(02).
  22278. 031600             07  PLU-SWA-CNTL       PIC X(02).
  22279. 031700         05  ALLOT-SWA-CNTL.
  22280. 031800             07  ALLOT-NUM-SWA-CNTL   PIC X(04).
  22281. 031900             07  PAST-NUM-SWA-CNTL    PIC X(02).
  22282. 032000         05  SWA-SWA-CNTL           PIC X(04).
  22283. 032100     03  STRATUM-SWA-CNTL           PIC X(04).
  22284. 032200 01  SWR-TABLE.
  22285. 032300     03  SWR-TAB   PIC X(48)  OCCURS 30 TIMES.
  22286. 032400 01  ACRE-SORT-REC-HLD.
  22287. 032500     03  FILLER           PIC X(04).
  22288. 032600     03  ADM-UNIT-H1.
  22289. 032700         05  ST-H1        PIC X(02).
  22290. 032800         05  DIS-H1       PIC X(02).
  22291. 032900         05  RA-H1        PIC X(02).
  22292. 033000         05  PLU-H1       PIC X(02).
  22293. 033100     03  ALLOT-H1.
  22294. 033200         05  ALLOT-NUM-H1     PIC X(04).
  22295. 033300         05  PAST-NUM-H1      PIC X(02).
  22296. 033400     03  FILLER           PIC X(30).
  22297. 033500     03  SWA-H1           PIC X(04).
  22298. 033600     03  FILLER           PIC X(16).
  22299. 033700     03  ACRES-H1         PIC 9(05).
  22300. 033800     03  OWNER-H1         PIC X(04).
  22301. 033900     03  JURIS-H1         PIC X(04).
  22302. 034000     03  MGT-ADM-H1       PIC X(04).
  22303. 034100     03  LAND-TYP-H1      PIC X(04).
  22304. 034200     03  FILLER           PIC X(01).
  22305. 034300 01  STRATUM-SORT-REC-HLD.
  22306. 034400     03  ADM-UNIT-H2.
  22307. 034500         05  ST-H2          PIC X(02).
  22308. 034600         05  DIS-H2         PIC X(02).
  22309. 034700         05  RA-H2          PIC X(02).
  22310. 034800         05  PLU-H2         PIC X(02).
  22311. 034900     03  SWAT-H2.
  22312. 035000         05  SWA-H2         PIC X(4).
  22313. 035100         05  TRANS-H2       PIC 99.
  22314. 035200     03  RNG-SITE-H2        PIC X(11).
  22315. 035300     03  STRATUM-H2         PIC 9(4).
  22316. 035400     03  PCT-SWA-H2         PIC 9(03).
  22317. 035500     03  ALLOT-H2.
  22318. 035600         05  ALLOT-NUM-H2   PIC X(04).
  22319. 035700         05  PAST-NUM-H2    PIC X(02).
  22320. 035800     03  COMP-AREA-H2       PIC X.
  22321. 035900     03  CLIM-ADJ-FCTR-H2   PIC 99V999.
  22322. 036000     03  COND-CLS-H2        PIC X.
  22323. 036100     03  FILLER-H2          PIC X(3).
  22324. 036200 01  VM-H3.
  22325. 036300     03  REC-H3.
  22326. 036400         05  REC-TYP-H3    PIC X(02).
  22327. 036500         05  FMT-NUM-H3    PIC X.
  22328. 036600         05  FMT-CD-H3     PIC X.
  22329. 036700     03  ADM-UNIT-H3.
  22330. 036800         05  ST-H3          PIC X(02).
  22331. 036900         05  DIS-H3         PIC X(02).
  22332. 037000     03  DATE-H3           PIC X(06).
  22333. 037100     03  ACT-H3            PIC X.
  22334. 037200     03  STOCK-RATE-KEY-H3 PIC 9.
  22335. 037300     03  RNG-SITE-H3       PIC X(11).
  22336. 037400     03  STOCKING-RATE-GRP-H3.
  22337. 037500         05  STOCKING-RATE-H3  PIC X(05)  OCCURS 5 TIMES.
  22338. 037600     03  FILLER            PIC X(32).
  22339. 037700 01  STOCKING-REC-H5.
  22340. 037800     03  OWNER-DATA.
  22341. 037900         05  ADM-UNIT-H5.
  22342. 038000             07  ST-H5         PIC X(02).
  22343. 038100             07  DIS-H5        PIC X(02).
  22344. 038200             07  RA-H5         PIC X(02).
  22345. 038300             07  PLU-H5        PIC X(02).
  22346. 038400         05  ALLOT-NUM-H5      PIC X(04).
  22347. 038500         05  PAST-NUM-H5       PIC X(02).
  22348. 038600         05  STRATUM-H5        PIC X(04).
  22349. 038700         05  RNG-SITE-H5       PIC X(11).
  22350. 038800         05  SWA-H5            PIC X(04).
  22351. 038900         05  COND-CLS-H5       PIC X(01).
  22352. 039000         05  ACRES-SWA-TOT-H5  PIC 9(06).
  22353. 039100         05  ACRES-OWNER-STRATUM-TOT-H5  PIC 9(06).
  22354. 039200         05  ACRES-STRATUM-SUM-H5  PIC 9(06).
  22355. 039300         05  PCT-OWNER-SWA-H5    PIC 9(03)V99.
  22356. 039400         05  FILLER              PIC XX.
  22357. 039500         05  OWNER-H5           PIC X(04).
  22358. 039600         05  JURIS-H5           PIC X(04).
  22359. 039700         05  MGT-ADM-H5         PIC X(04).
  22360. 039800         05  LAND-TYP-H5        PIC X(04).
  22361. 039900         05  FILLER             PIC X(03).
  22362. 040000     03  STOCK-RATE-KEY-H5  PIC 9.
  22363. 040100     03  STOCKING-RATE-GRP-H5.
  22364. 040200         05  STOCKING-RATE-H5   PIC X(05)  OCCURS 5 TIMES.
  22365. 040300     03  FILLER             PIC X(4).
  22366. 040400 01  HOLD-AREA.
  22367. 040500     03  BLM-ADM-HOLD.
  22368. 040600         05  ST-HOLD                    PIC XX.
  22369. 040700         05  DT-HOLD                    PIC XX.
  22370. 040800         05  RA-HOLD                    PIC XX.
  22371. 040900         05  PLU-HOLD                   PIC XX.
  22372. 041000     03  ALLOT-NUM-HOLD                 PIC X(4).
  22373. 041100     03  PASTURE-NUM-HOLD               PIC XX.
  22374. 041200     03  MAP-SRC-HOLD                   PIC X(4).
  22375. 041300     03  MTR-MER-CD-HOLD                PIC XX.
  22376. 041400 01  DATE-HOLD.
  22377. 041500     03  YEAR-H                         PIC 99.
  22378. 041600     03  MON-H                          PIC 99.
  22379. 041700     03  DAY-H                          PIC 99.
  22380. 041800 01  MONTH-TABLE                        PIC X(36) VALUE
  22381. 041900     "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC".
  22382. 042000 01  MONTH-LINE REDEFINES MONTH-TABLE.
  22383. 042100     03  ALPHA-MONTH                    PIC X(3) OCCURS 12.
  22384. 042200 01  HOLD-AREA.
  22385. 042300     03  FUNC-HOLD.
  22386. 042400         04  STATE-NAME                 PIC X(10).
  22387. 042500         04  FILLER                     PIC X(14).
  22388. 042600     03  EXPL-HOLD.
  22389. 042700         04  DIST-NAME                  PIC X(10).
  22390. 042800         04  FILLER                     PIC X.
  22391. 042900         04  RA-NAME                    PIC X(12).
  22392. 043000         04  FILLER                     PIC X.
  22393. 043100         04  PLU-NAME                   PIC X(15).
  22394. 043200         04  FILLER                     PIC X.
  22395. 043300     03  DIST-H                         PIC XX.
  22396. 043400 01  STOCK-RATE-HLD.
  22397. 043500     03  SRH   PIC X  OCCURS 5 TIMES.
  22398. 043600 COPY DBSTATUS OF TPCOBOLIB.
  22399. 043700 PROCEDURE DIVISION.
  22400. 043800 005-START SECTION.
  22401. 043900 010-SORT-ACRES.
  22402. 044000     SORT SORT-FILE ON ASCENDING KEY
  22403. 044100         SORT-KEY-SK1
  22404. 044200             INPUT PROCEDURE IS ACRE-SORT-INPUT
  22405. 044300             OUTPUT PROCEDURE IS ACRE-SUM-OUTPUT.
  22406. 044400 020-SORT-STRATUM.
  22407. 044500     SORT SORT-FILE-2 ON ASCENDING KEY
  22408. 044600         SORT-KEY-SK2
  22409. 044700             INPUT PROCEDURE IS STRATUM-SORT-INPUT
  22410. 044800             OUTPUT PROCEDURE IS STRATUM-SUM-OUTPUT.
  22411. 044900 025-SORT-SWA.
  22412. 045000     SORT SORT-FILE-3 ON ASCENDING KEY
  22413. 045100         SORT-KEY-SK3
  22414. 045200             INPUT PROCEDURE IS SWA-SORT-INPUT
  22415. 045300             OUTPUT PROCEDURE IS OWNER-SUM-OUTPUT.
  22416. 045400 027-SORT-OWNER-STOCKING.
  22417. 045500     SORT SORT-FILE-4 ON ASCENDING KEY
  22418. 045600         SORT-KEY-SK4
  22419. 045700             INPUT PROCEDURE IS RNG-SITE-SORT-INPUT
  22420. 045800             OUTPUT PROCEDURE IS STOCKING-SUM-OUTPUT.
  22421. 045900 029-END.
  22422. 046000     CLOSE STOCKING-FILE.
  22423. 046100     DISPLAY "END JOB".
  22424. 046200     STOP RUN.
  22425. 046300 ACRE-SORT-INPUT SECTION.
  22426. 046400 030-OPEN.
  22427. 046500     OPEN INPUT ACRE-FILE.
  22428. 046600 035-READ-ACRE.
  22429. 046700     READ ACRE-FILE
  22430. 046800         AT END GO TO 030-EXIT.
  22431. 046900     IF PAST-NUM-I1 = SPACE
  22432. 047000         MOVE ZERO TO PAST-NUM-I1.
  22433. 047100*    ADD 1 TO TEST-CNT-1.
  22434. 047200*    IF TEST-CNT-1 = 200 GO TO 030-EXIT.
  22435. 047300*    DISPLAY "AR = " ACRE-REC.
  22436. 047400     MOVE ADM-UNIT-I1 TO ADM-UNIT-SK1.
  22437. 047500     MOVE ALLOT-I1 TO ALLOT-SK1.
  22438. 047600     MOVE SWA-I1 TO SWA-SK1.
  22439. 047700     MOVE SPACE TO OWNER-SK1.
  22440. 047800     MOVE ACRE-REC TO DATA-SK1.
  22441. 047900     MOVE 1 TO KEY-SK1.
  22442. 048000     RELEASE SORT-REC.
  22443. 048100     MOVE ADM-UNIT-I1 TO ADM-UNIT-SK1.
  22444. 048200     MOVE ALLOT-I1 TO ALLOT-SK1.
  22445. 048300     MOVE SWA-I1 TO SWA-SK1.
  22446. 048400     MOVE OWNER-I1 TO OWNER-SK1.
  22447. 048500     MOVE ACRE-REC TO DATA-SK1.
  22448. 048600     MOVE 2 TO KEY-SK1.
  22449. 048700     RELEASE SORT-REC.
  22450. 048800     GO TO 035-READ-ACRE.
  22451. 048900 030-EXIT.
  22452. 049000     EXIT.
  22453. 049100 ACRE-SUM-OUTPUT SECTION.
  22454. 049200 040-OPEN.
  22455. 049300     OPEN OUTPUT ACRE-WORK-FILE.
  22456. 049400     INITIALIZE ACRE-SORT-REC-HLD.
  22457. 049500     INITIALIZE ACRE-WORK-REC.
  22458. 049600     CLOSE ACRE-FILE.
  22459. 049700 045-RETURN.
  22460. 049800     RETURN SORT-FILE
  22461. 049900         AT END
  22462. 050000             MOVE 1 TO SK1-SW
  22463. 050100             GO TO 050-SUM.
  22464. 050200*    DISPLAY "SR1= " SORT-REC.
  22465. 050300     IF ADM-UNIT-H1 = SPACE
  22466. 050400         MOVE ADM-UNIT-SK1 TO ADM-UNIT-H1
  22467. 050500         MOVE ALLOT-SK1 TO ALLOT-H1
  22468. 050600         MOVE SWA-SK1 TO SWA-H1.
  22469. 050700     IF (ADM-UNIT-SK1 NOT = ADM-UNIT-H1) OR
  22470. 050800         (ALLOT-SK1 NOT = ALLOT-H1) OR
  22471. 050900         (SWA-SK1 NOT = SWA-H1)
  22472. 051000             GO TO 050-SUM.
  22473. 051100     IF KEY-SK1 = 1
  22474. 051200         ADD ACRES-SK1 TO ACRES-SWA-TOT-HLD
  22475. 051300         GO TO 045-RETURN.
  22476. 051400     IF OWNER-H1 = SPACE
  22477. 051500         MOVE OWNER-SK1 TO OWNER-H1.
  22478. 051600     IF OWNER-SK1 = OWNER-H1
  22479. 051700         ADD ACRES-SK1 TO ACRES-OWNER-TOT-HLD
  22480. 051800         MOVE DATA-SK1 TO ACRE-SORT-REC-HLD
  22481. 051900         GO TO 045-RETURN.
  22482. 052000     MOVE 1 TO OWNER-SW.
  22483. 052100 050-SUM.
  22484. 052200     MOVE ADM-UNIT-H1 TO ADM-UNIT-W1.
  22485. 052300     MOVE ALLOT-NUM-H1 TO ALLOT-NUM-W1.
  22486. 052400     MOVE PAST-NUM-H1 TO PAST-NUM-W1.
  22487. 052500     MOVE SWA-H1 TO SWA-W1.
  22488. 052600     MOVE OWNER-H1 TO OWNER-W1.
  22489. 052700     MOVE JURIS-H1 TO JURIS-W1.
  22490. 052800     MOVE MGT-ADM-H1 TO MGT-ADM-W1.
  22491. 052900     MOVE LAND-TYP-H1 TO LAND-TYP-W1.
  22492. 053000     MOVE ACRES-OWNER-TOT-HLD TO ACRES-OWNER-TOT-W1.
  22493. 053100     MOVE ACRES-SWA-TOT-HLD TO ACRES-SWA-TOT-W1.
  22494. 053200     MULTIPLY 100 BY ACRES-OWNER-TOT-HLD.
  22495. 053300     DIVIDE ACRES-OWNER-TOT-HLD BY
  22496. 053400         ACRES-SWA-TOT-HLD GIVING PCT-OWNER-SWA-W1 ROUNDED.
  22497. 053500     MOVE ZERO TO ACRES-OWNER-TOT-HLD.
  22498. 053600*    DISPLAY "AWR= " ACRE-WORK-REC.
  22499. 053700     WRITE ACRE-WORK-REC.
  22500. 053800     INITIALIZE ACRE-WORK-REC.
  22501. 053900     IF SK1-SW = 1 GO TO 040-EXIT.
  22502. 054000     IF OWNER-SW = 1
  22503. 054100         MOVE ZERO TO OWNER-SW
  22504. 054200         MOVE ACRES-SK1 TO ACRES-OWNER-TOT-HLD
  22505. 054300         MOVE DATA-SK1 TO ACRE-SORT-REC-HLD
  22506. 054400         GO TO 045-RETURN.
  22507. 054500     MOVE ACRES-SK1 TO ACRES-SWA-TOT-HLD.
  22508. 054600     MOVE DATA-SK1 TO ACRE-SORT-REC-HLD.
  22509. 054700     MOVE SPACE TO OWNER-H1.
  22510. 054800     GO TO 045-RETURN.
  22511. 054900 040-EXIT.
  22512. 055000     EXIT.
  22513. 055100 STRATUM-SORT-INPUT SECTION.
  22514. 055200 060-OPEN.
  22515. 055300     OPEN INPUT STRATUM-FILE.
  22516. 055400     CLOSE ACRE-WORK-FILE.
  22517. 055500 060-READ-STRATUM.
  22518. 055600     READ STRATUM-FILE
  22519. 055700         AT END GO TO 060-EXIT.
  22520. 055800     IF PAST-NUM-I2 = SPACE
  22521. 055900         MOVE ZERO TO PAST-NUM-I2.
  22522. 056000*    ADD 1 TO TEST-CNT-2.
  22523. 056100*    IF TEST-CNT-2 = 200 GO TO 060-EXIT.
  22524. 056200*    DISPLAY "STRAT-REC= " STRATUM-REC.
  22525. 056300     MOVE ADM-UNIT-I2 TO ADM-UNIT-SK2.
  22526. 056400     MOVE ALLOT-I2 TO ALLOT-SK2.
  22527. 056500     MOVE SWAT-I2 TO SWAT-SK2.
  22528. 056600     MOVE STRATUM-I2 TO STRATUM-SK2.
  22529. 056700     MOVE STRATUM-REC TO DATA-SK2.
  22530. 056800     RELEASE SORT-REC-2.
  22531. 056900     GO TO 060-READ-STRATUM.
  22532. 057000 060-EXIT.
  22533. 057100     EXIT.
  22534. 057200 STRATUM-SUM-OUTPUT SECTION.
  22535. 057300 070-OPEN.
  22536. 057400     OPEN OUTPUT STRATUM-WORK-FILE.
  22537. 057500     CLOSE STRATUM-FILE.
  22538. 057600     INITIALIZE STRATUM-SORT-REC-HLD.
  22539. 057700 075-RETURN.
  22540. 057800     RETURN SORT-FILE-2
  22541. 057900         AT END
  22542. 058000             MOVE 1 TO SK2-SW
  22543. 058100             GO TO 075-SUM.
  22544. 058200*    DISPLAY "SR2= " SORT-REC-2.
  22545. 058300     IF ADM-UNIT-H2 = SPACE
  22546. 058400         MOVE ADM-UNIT-SK2 TO ADM-UNIT-H2
  22547. 058500         MOVE ALLOT-SK2 TO ALLOT-H2
  22548. 058600         MOVE STRATUM-SK2 TO STRATUM-H2.
  22549. 058700     IF (ADM-UNIT-SK2 NOT = ADM-UNIT-H2) OR
  22550. 058800         (ALLOT-SK2 NOT = ALLOT-H2) OR
  22551. 058900         (STRATUM-SK2 NOT = STRATUM-H2)
  22552. 059000             GO TO 075-SUM.
  22553. 059100     IF SWA-H2 = SPACE
  22554. 059200         MOVE SWAT-SK2 TO SWAT-H2.
  22555. 059300     IF SWAT-SK2 = SWAT-H2
  22556. 059400         MOVE DATA-SK2 TO STRATUM-SORT-REC-HLD
  22557. 059500         ADD PCT-SWA-H2 TO PCT-SWA-STRATUM-TOT-HLD
  22558. 059600         GO TO 075-RETURN.
  22559. 059700 075-SUM.
  22560. 059800     MOVE STRATUM-SORT-REC-HLD TO STRATUM-WORK-REC.
  22561. 059900     MOVE PCT-SWA-STRATUM-TOT-HLD TO PCT-SWA-TOT-W2.
  22562. 060000*    DISPLAY "SWR= " STRATUM-WORK-REC.
  22563. 060100     WRITE STRATUM-WORK-REC.
  22564. 060200     IF SK2-SW = 1
  22565. 060300         GO TO 070-EXIT.
  22566. 060400     MOVE DATA-SK2 TO STRATUM-SORT-REC-HLD.
  22567. 060500     MOVE PCT-SWA-H2 TO PCT-SWA-STRATUM-TOT-HLD.
  22568. 060600     GO TO 075-RETURN.
  22569. 060700 070-EXIT.
  22570. 060800     EXIT.
  22571. 060900 SWA-SORT-INPUT SECTION.
  22572. 061000 080-OPEN.
  22573. 061100     CLOSE STRATUM-WORK-FILE.
  22574. 061200     OPEN INPUT STRATUM-WORK-FILE.
  22575. 061300 080-READ-SWA.
  22576. 061400     READ STRATUM-WORK-FILE
  22577. 061500         AT END GO TO 080-EXIT.
  22578. 061600*    DISPLAY "SWR= " STRATUM-WORK-REC.
  22579. 061700     MOVE ADM-UNIT-W2 TO ADM-UNIT-SK3.
  22580. 061800     MOVE ALLOT-W2 TO ALLOT-SK3.
  22581. 061900     MOVE SWA-W2 TO SWA-SK3.
  22582. 062000     MOVE STRATUM-W2 TO STRATUM-SK3.
  22583. 062100     MOVE STRATUM-WORK-REC TO DATA-SK3.
  22584. 062200     RELEASE SORT-REC-3.
  22585. 062300     GO TO 080-READ-SWA.
  22586. 062400 080-EXIT.
  22587. 062500     EXIT.
  22588. 062600 OWNER-SUM-OUTPUT SECTION.
  22589. 062700 090-OPEN.
  22590. 062800     CLOSE STRATUM-WORK-FILE.
  22591. 062900     OPEN OUTPUT OWNER-WORK-FILE.
  22592. 063000     MOVE SPACE TO ACRE-CNTL-HLD STRATUM-CNTL-HLD.
  22593. 063100     MOVE SPACE TO SWR-TABLE.
  22594. 063200     OPEN INPUT ACRE-WORK-FILE.
  22595. 063300 095-RETURN.
  22596. 063400     RETURN SORT-FILE-3
  22597. 063500         AT END
  22598. 063600             MOVE 1 TO SK3-SW
  22599. 063700             GO TO 098-PASS.
  22600. 063800*    DISPLAY "SR3= " SORT-REC-3.
  22601. 063900     IF SUB > 29 DISPLAY "SWA TABLE OVERSIZE  SUB = " SUB
  22602. 064000         CALL "ABORT".
  22603. 064100 097-LOAD.
  22604. 064200     IF SK3-SW = 1 GO TO 105-CHK-END.
  22605. 064300     IF STRATUM-CNTL-HLD = SPACE
  22606. 064400         MOVE ADM-UNIT-SK3 TO ADM-UNIT-SWA-CNTL
  22607. 064500         MOVE ALLOT-SK3 TO ALLOT-SWA-CNTL
  22608. 064600         MOVE SWA-SK3 TO SWA-SWA-CNTL
  22609. 064700         MOVE STRATUM-SK3 TO STRATUM-SWA-CNTL
  22610. 064800         ADD 1 TO SUB
  22611. 064900         MOVE DATA-SK3 TO SWR-TAB (SUB)
  22612. 065000         GO TO 095-RETURN.
  22613. 065100*    DISPLAY "SCH= " STRATUM-CNTL-HLD.
  22614. 065200     IF STRATUM-CNTL-HLD = SORT-KEY-SK3
  22615. 065300         GO TO 095-RETURN.
  22616. 065400     IF SWA-CNTL-HLD = SWA-CNTL-SK3
  22617. 065500         MOVE STRATUM-SK3 TO STRATUM-SWA-CNTL
  22618. 065600         ADD 1 TO SUB
  22619. 065700         MOVE DATA-SK3 TO SWR-TAB (SUB)
  22620. 065800         GO TO 095-RETURN.
  22621. 065900 098-PASS.
  22622. 066000     IF SWA-CNTL-HLD = ACRE-CNTL-HLD
  22623. 066100         GO TO 100-MOVE-OWNER-WORK.
  22624. 066200 100-READ-ACRE-WORK.
  22625. 066300     READ ACRE-WORK-FILE
  22626. 066400         AT END
  22627. 066500             MOVE 1 TO END-SW
  22628. 066600             GO TO 100-EXIT.
  22629. 066700*    DISPLAY "AWR= " ACRE-WORK-REC.
  22630. 066800     MOVE ADM-UNIT-W1 TO ADM-UNIT-ACRE-CNTL.
  22631. 066900     MOVE ALLOT-W1 TO ALLOT-ACRE-CNTL.
  22632. 067000     MOVE SWA-W1 TO SWA-ACRE-CNTL.
  22633. 067100     IF ACRE-CNTL-HLD > SWA-CNTL-HLD
  22634. 067200         MOVE ZERO TO SUB
  22635. 067300         MOVE SPACE TO SWR-TABLE STRATUM-CNTL-HLD
  22636. 067400         GO TO 097-LOAD.
  22637. 067500     IF ACRE-CNTL-HLD < SWA-CNTL-HLD
  22638. 067600         DISPLAY "ACH= " ACRE-CNTL-HLD
  22639. 067700         DISPLAY "SCH= " SWA-CNTL-HLD
  22640. 067800         GO TO 100-READ-ACRE-WORK.
  22641. 067900 100-MOVE-OWNER-WORK.
  22642. 068000     MOVE ZERO TO SUB.
  22643. 068100 100-LOOP.
  22644. 068200     MOVE SPACE TO OWNER-WORK-REC.
  22645. 068300     MOVE ADM-UNIT-W1 TO ADM-UNIT-W3.
  22646. 068400     MOVE ALLOT-NUM-W1 TO ALLOT-NUM-W3.
  22647. 068500     MOVE PAST-NUM-W1 TO PAST-NUM-W3.
  22648. 068600     MOVE SWA-W1 TO SWA-W3.
  22649. 068700     MOVE OWNER-W1 TO OWNER-W3.
  22650. 068800     MOVE JURIS-W1 TO JURIS-W3.
  22651. 068900     MOVE MGT-ADM-W1 TO MGT-ADM-W3.
  22652. 069000     MOVE LAND-TYP-W1 TO LAND-TYP-W3.
  22653. 069100     MOVE PCT-OWNER-SWA-W1 TO PCT-SWA-OWNER-HLD.
  22654. 069200     MOVE ACRES-SWA-TOT-W1 TO ACRES-SWA-TOT-W3.
  22655. 069300     ADD 1 TO SUB.
  22656. 069400     IF SWR-TAB (SUB) = SPACE
  22657. 069500       GO TO 100-READ-ACRE-WORK.
  22658. 069600     MOVE SWR-TAB (SUB) TO STRATUM-SORT-REC-HLD.
  22659. 069700     MOVE STRATUM-H2 TO STRATUM-W3.
  22660. 069800     MOVE RNG-SITE-H2 TO RNG-SITE-W3.
  22661. 069900     MOVE COND-CLS-H2 TO COND-CLS-W3.
  22662. 070000     MOVE PCT-SWA-H2 TO PCT-SWA-STRATUM-TOT-HLD.
  22663. 070100     MULTIPLY PCT-SWA-OWNER-RD BY PCT-SWA-STRATUM-RD
  22664. 070200         GIVING PCT-SWA-OWNER-STRATUM-RD ROUNDED.
  22665. 070300     MULTIPLY ACRES-SWA-TOT-W1 BY PCT-SWA-OWNER-STRATUM-RD
  22666. 070400         GIVING ACRES-OWNER-SWA-STRATUM-HLD ROUNDED.
  22667. 070500     MOVE ACRES-OWNER-SWA-STRATUM-HLD TO
  22668. 070600         ACRES-OWNER-STRATUM-TOT-W3.
  22669. 070700     MOVE PCT-SWA-OWNER-STRATUM-HLD TO
  22670. 070800         PCT-OWNER-SWA-W3.
  22671. 070900*    DISPLAY "OWR= " OWNER-WORK-REC.
  22672. 071000     WRITE OWNER-WORK-REC.
  22673. 071100     GO TO 100-LOOP.
  22674. 071200 100-EXIT.
  22675. 071300     EXIT.
  22676. 071400 105-CHK-END.
  22677. 071500     IF END-SW NOT = 1
  22678. 071600         DISPLAY "ACRES-WORK-FILE NOT AT END"
  22679. 071700         STOP RUN.
  22680. 071800 090-EXIT.
  22681. 071900     EXIT.
  22682. 072000 RNG-SITE-SORT-INPUT SECTION.
  22683. 072100 110-OPEN.
  22684. 072200     CLOSE OWNER-WORK-FILE.
  22685. 072300     CLOSE ACRE-WORK-FILE.
  22686. 072400     OPEN INPUT OWNER-WORK-FILE.
  22687. 072500     OPEN INPUT VM-FILE.
  22688. 072600 110-READ-OWNER.
  22689. 072700     READ OWNER-WORK-FILE AT END
  22690. 072800         MOVE SPACE TO SORT-REC-4
  22691. 072900          GO TO 115-RELEASE-TOTAL.
  22692. 073000*    DISPLAY "OWR= " STRATUM-WORK-REC.
  22693. 073100     MOVE RNG-SITE-W3 TO RNG-SITE-W3-HLD.
  22694. 073200     MOVE ALLOT-W3 TO ALLOT-W3-HLD.
  22695. 073300     MOVE STRATUM-W3 TO STRATUM-W3-HLD.
  22696. 073400     MOVE ALLOT-NUM-W3 TO ALLOT-NUM-W3-HLD.
  22697. 073500     MOVE PAST-NUM-W3 TO PAST-NUM-W3-HLD.
  22698. 073600     IF CNTL-SK4-HLD = SPACE
  22699. 073700         MOVE CNTL-W3-HLD TO CNTL-SK4-HLD.
  22700. 073800     IF CNTL-W3-HLD NOT = CNTL-SK4-HLD
  22701. 073900         PERFORM 115-RELEASE-TOTAL
  22702. 074000         MOVE CNTL-W3-HLD TO CNTL-SK4-HLD.
  22703. 074100     MOVE 2 TO KEY-SK4.
  22704. 074200     MOVE OWNER-WORK-REC TO DATA-SK4.
  22705. 074300     MOVE CNTL-W3-HLD TO CNTL-SK4.
  22706. 074400     ADD ACRES-OWNER-STRATUM-TOT-W3 TO ACRES-STRATUM-SUM-HLD.
  22707. 074500     RELEASE SORT-REC-4.
  22708. 074600     GO TO 110-READ-OWNER.
  22709. 074700 115-RELEASE-TOTAL.
  22710. 074800     MOVE SPACE TO SORT-REC-4.
  22711. 074900     MOVE 0 TO KEY-SK4.
  22712. 075000     MOVE CNTL-SK4-HLD TO CNTL-SK4.
  22713. 075100     MOVE ACRES-STRATUM-SUM-HLD TO ACRES-STRATUM-SUM-SK4.
  22714. 075200     MOVE ZERO TO ACRES-STRATUM-SUM-HLD.
  22715. 075300     RELEASE SORT-REC-4.
  22716. 075400 110-EXIT.
  22717. 075500     EXIT.
  22718. 075600 120-READ-VM.
  22719. 075700     READ VM-FILE
  22720. 075800         AT END GO TO 120-EXIT.
  22721. 075900     MOVE RNG-SITE-I3 TO RNG-SITE-SK4.
  22722. 076000     MOVE ZERO TO STRATUM-SK4 ALLOT-SK4.
  22723. 076100     MOVE 1 TO KEY-SK4.
  22724. 076200     MOVE ZERO TO X Y.
  22725. 076300 121-LP.
  22726. 076400     IF X = 5 GO TO 123-RELEASE.
  22727. 076500     ADD 1 TO X.
  22728. 076600     MOVE STOCKING-RATE-I3 (X) TO STOCK-RATE-HLD.
  22729. 076700 122-LP.
  22730. 076800     IF Y = 5
  22731. 076900         MOVE STOCK-RATE-HLD TO STOCKING-RATE-I3 (X)
  22732. 077000         MOVE ZERO TO Y
  22733. 077100         GO TO 121-LP.
  22734. 077200    IF SRH (Y) = SPACE MOVE ZERO TO SRH (Y).
  22735. 077300    ADD 1 TO Y.
  22736. 077400    GO TO 122-LP.
  22737. 077500 123-RELEASE.
  22738. 077600     MOVE VM-REC TO DATA-SK4.
  22739. 077700     RELEASE SORT-REC-4.
  22740. 077800     GO TO 120-READ-VM.
  22741. 077900 120-EXIT.
  22742. 078000     EXIT.
  22743. 078100 STOCKING-SUM-OUTPUT SECTION.
  22744. 078200 130-OPEN.
  22745. 078300     OPEN OUTPUT STOCKING-FILE.
  22746. 078400         MOVE SPACE TO STOCKING-REC-H5
  22747. 078500 130-RETURN.
  22748. 078600     RETURN SORT-FILE-4
  22749. 078700         AT END
  22750. 078800             GO TO 130-EXIT.
  22751. 078900*    ADD 1 TO TEST-CNT-1.
  22752. 079000*    IF TEST-CNT-1 < 300
  22753. 079100*        DISPLAY "SR4= " SORT-REC-4.
  22754. 079200     IF (KEY-PREV = 2 OR 1) AND
  22755. 079300         (KEY-SK4 = ZERO)
  22756. 079400         MOVE ZERO TO ACRES-STRATUM-SUM-HLD.
  22757. 079500     MOVE KEY-SK4 TO KEY-PREV.
  22758. 079600     IF KEY-SK4 = 0
  22759. 079700         ADD ACRES-STRATUM-SUM-SK4 TO ACRES-STRATUM-SUM-HLD
  22760. 079800         GO TO 130-RETURN.
  22761. 079900     IF (KEY-SK4 = 1) AND
  22762. 080000        (RNG-SITE-SK4 = RNG-SITE-H5)
  22763. 080100         DISPLAY "VM - DUPLICATE RNG-SITE= " DATA-SK4
  22764. 080200             GO TO 130-RETURN.
  22765. 080300     IF KEY-SK4 = 1
  22766. 080400         MOVE DATA-SK4 TO VM-H3
  22767. 080500         MOVE SPACE TO STOCKING-REC-H5
  22768. 080600         MOVE RNG-SITE-SK4 TO RNG-SITE-H5
  22769. 080700         MOVE STOCKING-RATE-GRP-H3 TO STOCKING-RATE-GRP-H5
  22770. 080800         MOVE STOCK-RATE-KEY-H3 TO STOCK-RATE-KEY-H5
  22771. 080900         GO TO 130-RETURN.
  22772. 081000     IF RNG-SITE-SK4 NOT = RNG-SITE-H5
  22773. 081100         MOVE SPACE TO STOCKING-REC-H5.
  22774. 081200     MOVE DATA-SK4 TO OWNER-DATA.
  22775. 081300     MOVE ACRES-STRATUM-SUM-HLD TO ACRES-STRATUM-SUM-H5.
  22776. 081400     WRITE STOCKING-REC FROM STOCKING-REC-H5.
  22777. 081500     GO TO 130-RETURN.
  22778. 081600 130-EXIT.
  22779. 081700     EXIT.
  22780. 081800 DUMMY SECTION.
  22781. 081900 999-END.
  22782. 000000*-----------------------------------------------------------------
  22783. 000100 IDENTIFICATION DIVISION.
  22784. 000200 PROGRAM-ID. ES526P.
  22785. 000300*        ECOLOGICAL CONDITION CLASS/EST. STOCKING RATE (P01B).
  22786. 000400*
  22787. 000500 AUTHOR. RON BAKER.
  22788. 000600 INSTALLATION.         BLM.
  22789. 000700 DATE-WRITTEN.         NOV 1981.
  22790. 000800 ENVIRONMENT DIVISION.
  22791. 000900 CONFIGURATION SECTION.
  22792. 001000 SOURCE-COMPUTER.      LEVEL-66-ASCII.
  22793. 001100 OBJECT-COMPUTER.      LEVEL-66-ASCII SEQUENCE IS EBCDIC.
  22794. 001200 INPUT-OUTPUT SECTION.
  22795. 001300 FILE-CONTROL.
  22796. 001400     SELECT  VM-COND-LIST-FILE  ASSIGN P1
  22797. 001500             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  22798. 001600     SELECT  RNG-SITE-WORK-FILE  ASSIGN W1
  22799. 001700             ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  22800. 001800     SELECT STOCKING-FILE ASSIGN TO I1
  22801. 001900         ORGANIZATION IS GFRC SEQUENTIAL WITH SSF.
  22802. 002000     SELECT SORT-FILE ASSIGN TO S1 S2 S3.
  22803. 002100     SELECT SORT-FILE-2 ASSIGN TO S1 S2 S3.
  22804. 002200 DATA DIVISION.
  22805. 002300 SUB-SCHEMA SECTION.
  22806. 002400 DB  CODVAL2 WITHIN BLMDIC.
  22807. 002500 FILE SECTION.
  22808. 002600 FD  STOCKING-FILE
  22809. 002700      CODE-SET IS GBCD
  22810. 002800     LABEL RECORD IS STANDARD.
  22811. 002900 01  STOCKING-REC.
  22812. 003000     03  ADM-UNIT-I1.
  22813. 003100         05  ST-I1         PIC X(02).
  22814. 003200         05  DIS-I1        PIC X(02).
  22815. 003300         05  RA-I1         PIC X(02).
  22816. 003400         05  PLU-I1        PIC X(02).
  22817. 003500     03  ALLOT-I1.
  22818. 003600         05  ALLOT-NUM-I1      PIC X(04).
  22819. 003700         05  PAST-NUM-I1       PIC X(02).
  22820. 003800     03  STRATUM-I1        PIC X(04).
  22821. 003900     03  RNG-SITE-I1       PIC X(11).
  22822. 004000     03  SWA-I1            PIC X(04).
  22823. 004100     03  COND-CLS-I1       PIC X(01).
  22824. 004200     03  ACRES-SWA-TOT-I1  PIC 9(06).
  22825. 004300     03  ACRES-OWNER-STRATUM-TOT-I1  PIC 9(06).
  22826. 004400     03  ACRES-STRATUM-SUM-I1  PIC 9(06).
  22827. 004500     03  PCT-OWNER-SWA-I1    PIC 9(03)V99.
  22828. 004600     03  FILLER              PIC XX.
  22829. 004700     03  OWNER-I1           PIC X(04).
  22830. 004800     03  JURIS-I1           PIC X(04).
  22831. 004900     03  MGT-ADM-I1         PIC X(04).
  22832. 005000     03  LAND-TYP-I1        PIC X(04).
  22833. 005100     03  FILLER             PIC X(03).
  22834. 005200     03  STOCK-RATE-KEY-I1  PIC 9.
  22835. 005300     03  STOCKING-RATE-GRP-I1.
  22836. 005400         05  STOCKING-RATE-I1   PIC X(05)  OCCURS 5 TIMES.
  22837. 005500     03  FILLER             PIC X(04).
  22838. 005600 FD  RNG-SITE-WORK-FILE
  22839. 005700      CODE-SET IS GBCD
  22840. 005800     LABEL RECORD IS STANDARD.
  22841. 005900 01  RNG-SITE-WORK-REC.
  22842. 006000     03  ADM-UNIT-W1.
  22843. 006100         05  ST-W1         PIC X(02).
  22844. 006200         05  DIS-W1        PIC X(02).
  22845. 006300         05  RA-W1         PIC X(02).
  22846. 006400         05  PLU-W1        PIC X(02).
  22847. 006500     03  ALLOT-W1.
  22848. 006600         05  ALLOT-NUM-W1      PIC X(04).
  22849. 006700         05  PAST-NUM-W1       PIC X(02).
  22850. 006800     03  RNG-SITE-W1       PIC X(11).
  22851. 006900     03  OWNER-W1          PIC X(04).
  22852. 007000     03  ACRES-W1          PIC 9(07).
  22853. 007100     03  EST-AUMS-PRES-W1   PIC 9(7)V99.
  22854. 007200     03  EST-AUMS-POTN-W1   PIC 9(7)V99.
  22855. 007300     03  COND-SUB-W1      PIC 9.
  22856. 007400     03  FILLER             PIC X(05).
  22857. 007500 FD  VM-COND-LIST-FILE
  22858. 007600     CODE-SET IS GBCD
  22859. 007700     LABEL RECORDS ARE STANDARD
  22860. 007800     DATA RECORD IS VM-COND-LIST-FILE.
  22861. 007900 01  VM-COND-LIST-REC      PIC X(132).
  22862. 008000 SD  SORT-FILE
  22863. 008100     DATA RECORD IS SORT-REC.
  22864. 008200 01  SORT-REC.
  22865. 008300     03  SORT-KEY.
  22866. 008400         05  ADM-UNIT-SK1    PIC X(08).
  22867. 008500         05  ALLOT-SK1.
  22868. 008600             07  ALLOT-NUM-SK1   PIC X(04).
  22869. 008700             07  PAST-NUM-SK1    PIC XX.
  22870. 008800         05  STRATUM-SK1     PIC X(04).
  22871. 008900         05  OWNER-SK1       PIC X(04).
  22872. 009000         05  RNG-SITE-SK1   PIC X(11).
  22873. 009100     03  DATA-SK1            PIC X(102).
  22874. 009200 SD  SORT-FILE-2
  22875. 009300     DATA RECORD IS SORT-REC-2.
  22876. 009400 01  SORT-REC-2.
  22877. 009500     03  SORT-KEY-2.
  22878. 009600         05  KEY-SK2         PIC 9.
  22879. 009700         05  ADM-UNIT-SK2    PIC X(08).
  22880. 009800         05  ALLOT-SK2.
  22881. 009900             07  ALLOT-NUM-SK2   PIC X(04).
  22882. 010000             07  PAST-NUM-SK2    PIC XX.
  22883. 010100         05  RNG-SITE-SK2.
  22884. 010200             07  OWNER-SK2   PIC X(04).
  22885. 010300             07  COND-SUB-SK2 PIC 9.
  22886. 010400             07  FILLER      PIC X(06).
  22887. 010500     03  DATA-SK2            PIC X(60).
  22888. 010600 WORKING-STORAGE SECTION.
  22889. 010700 77  PG-CNT                PIC 9(5)  VALUE ZERO.
  22890. 010800 77  LINE-HLD              PIC 9  VALUE 1.
  22891. 010900 77  LINE-CNT              PIC 9(2)  VALUE 99.
  22892. 011000 77  END-SW                PIC 9  VALUE ZERO.
  22893. 011100 77  INV-SW                PIC 9  VALUE ZERO.
  22894. 011200 77  ADM-SW                PIC 9  VALUE ZERO.
  22895. 011300 77  RNG-SW                PIC 9  VALUE ZERO.
  22896. 011400 77  OWN-SW                PIC 9  VALUE ZERO.
  22897. 011500 77  END-OWN-SW                PIC 9  VALUE ZERO.
  22898. 011600 77  END-OWN2-SW                PIC 9  VALUE ZERO.
  22899. 011700 77  COND-SW                PIC 9  VALUE ZERO.
  22900. 011800 77  COND-SUB                PIC 9  VALUE ZERO.
  22901. 011900 77  END-RNG-SW            PIC 9  VALUE ZERO.
  22902. 012000 77  END-RNG2-SW            PIC 9  VALUE ZERO.
  22903. 012100 77  OFLO-SW               PIC 9  VALUE 1.
  22904. 012200 77  SDRP-SW               PIC 9  VALUE 1.
  22905. 012300 77  SUB                   PIC 9  VALUE ZERO.
  22906. 012400 77  OWNER-P4-HLD          PIC X(04)  VALUE SPACE.
  22907. 012500 77  INVENTORY             PIC X(04).
  22908. 012600 77  RNG-SITE-PREV-HLD     PIC X(11).
  22909. 012700 77  COND-CLS-PREV-HLD     PIC X(01).
  22910. 012800 77  STRATUM-PREV-HLD      PIC X(04).
  22911. 012900 01  TOT-CNTL.
  22912. 013000     03  ADM-UNIT-CNTL       PIC X(08).
  22913. 013100     03  ALLOT-CNTL.
  22914. 013200         05  ALLOT-NUM-CNTL  PIC X(04).
  22915. 013300         05  PAST-NUM-CNTL   PIC XX.
  22916. 013400     03  STRATUM-CNTL        PIC X(04).
  22917. 013500     03  OWNER-CNTL          PIC X(04).
  22918. 013600     03  RNG-SITE-CNTL          PIC X(11).
  22919. 013700 01  RNG-CNTL.
  22920. 013800     03  KEY-RNG-CNTL            PIC 9.
  22921. 013900     03  ADM-UNIT-RNG-CNTL       PIC X(08).
  22922. 014000     03  ALLOT-RNG-RNG-CNTL.
  22923. 014100         05  ALLOT-RNG-CNTL.
  22924. 014200             07  ALLOT-NUM-RNG-CNTL  PIC X(04).
  22925. 014300             07  PAST-NUM-RNG-CNTL   PIC XX.
  22926. 014400     03  RNG-SITE-RNG-CNTL.
  22927. 014500             07  OWNER-RNG-CNTL   PIC X(04).
  22928. 014600             07  COND-SUB-RNG-CNTL  PIC 9.
  22929. 014700             07  FILLER           PIC X(06).
  22930. 014800 01  ALLOT-P3-HLD.
  22931. 014900     03  ALLOT-NUM-P3-HLD     PIC X(04).
  22932. 015000     03  PAST-NUM-P3-HLD      PIC X(02).
  22933. 015100 01  TOTALS-HLD.
  22934. 015200     03  ACRES-CAL                 PIC 9(09)  VALUE ZERO.
  22935. 015300     03  PCT-CAL                  PIC 999  VALUE ZERO.
  22936. 015400     03  ACRES-PLU-SUM            PIC 9(07)  VALUE ZERO.
  22937. 015500     03  ACRES-INV-SUM            PIC 9(07)  VALUE ZERO.
  22938. 015600     03  ACRES-COND-TOT            PIC 9(07)  VALUE ZERO.
  22939. 015700     03  AUMS-PRES-COND-TOT        PIC 9(7)V99  VALUE ZERO.
  22940. 015800     03  AUMS-POTN-COND-TOT        PIC 9(07)V99  VALUE ZERO.
  22941. 015900     03  ACRES-SWA-OWNER-TOT       PIC 9(07)  VALUE ZERO.
  22942. 016000     03  ACRES-OWNER-TOT           PIC 9(07)  VALUE ZERO.
  22943. 016100     03  AUMS-PRES-OWNER-TOT       PIC 9(7)V99  VALUE ZERO.
  22944. 016200     03  AUMS-POTN-OWNER-TOT       PIC 9(07)V99  VALUE ZERO.
  22945. 016300     03  ACRES-STRATUM-TOT         PIC 9(07)  VALUE ZERO.
  22946. 016400     03  AUMS-PRES-STRATUM-TOT     PIC 9(7)V99  VALUE ZERO.
  22947. 016500     03  AUMS-POTN-STRATUM-TOT     PIC 9(07)V99  VALUE ZERO.
  22948. 016600     03  ACRES-RNG-SITE-TOT        PIC 9(07)  VALUE ZERO.
  22949. 016700     03  AUMS-PRES-RNG-SITE-TOT    PIC 9(7)V99  VALUE ZERO.
  22950. 016800     03  AUMS-POTN-RNG-SITE-TOT    PIC 9(07)V99  VALUE ZERO.
  22951. 016900     03  ACRES-PAST-TOT        PIC 9(07)  VALUE ZERO.
  22952. 017000     03  AUMS-PRES-PAST-TOT    PIC 9(7)V99  VALUE ZERO.
  22953. 017100     03  AUMS-POTN-PAST-TOT    PIC 9(07)V99  VALUE ZERO.
  22954. 017200     03  ACRES-ALOT-TOT        PIC 9(07)  VALUE ZERO.
  22955. 017300     03  AUMS-PRES-ALOT-TOT    PIC 9(7)V99  VALUE ZERO.
  22956. 017400     03  AUMS-POTN-ALOT-TOT    PIC 9(07)V99  VALUE ZERO.
  22957. 017500     03  ACRES-PLU-TOT           PIC 9(07)  VALUE ZERO.
  22958. 017600     03  AUMS-PRES-PLU-TOT       PIC 9(7)V99  VALUE ZERO.
  22959. 017700     03  AUMS-POTN-PLU-TOT       PIC 9(07)V99  VALUE ZERO.
  22960. 017800     03  ACRES-INV-TOT           PIC 9(07)  VALUE ZERO.
  22961. 017900     03  AUMS-PRES-INV-TOT       PIC 9(7)V99  VALUE ZERO.
  22962. 018000     03  AUMS-POTN-INV-TOT       PIC 9(07)V99  VALUE ZERO.
  22963. 018100     03  PCT-OWNER-TOT             PIC 9V99  VALUE ZERO.
  22964. 018200     03  PCT-OWNER-TOT-RD REDEFINES PCT-OWNER-TOT
  22965. 018300                                   PIC 999.
  22966. 018400 01  COND-SUM-TOTALS.
  22967. 018500     03  COND-PLU-SUM.
  22968. 018600         05  COND-PLU    OCCURS 5 TIMES.
  22969. 018700             07  ACRES-COND-PLU-SUM      PIC 9(07)V99.
  22970. 018800             07  AUMS-PRES-COND-PLU-SUM  PIC 9(07)V99.
  22971. 018900             07  AUMS-POTN-COND-PLU-SUM  PIC 9(07)V99.
  22972. 019000     03  COND-INV-SUM.
  22973. 019100         05  COND-INV    OCCURS 5 TIMES.
  22974. 019200             07  ACRES-COND-INV-SUM      PIC 9(07)V99.
  22975. 019300             07  AUMS-PRES-COND-INV-SUM  PIC 9(07)V99.
  22976. 019400             07  AUMS-POTN-COND-INV-SUM  PIC 9(07)V99.
  22977. 019500 01  HDR-1.
  22978. 019600     03  FILLER          PIC  X(07)
  22979. 019700         VALUE " DATE: ".
  22980. 019800     03  HDR-MO        PIC  X(04).
  22981. 019900     03  FILLER          PIC  X(01)
  22982. 020000         VALUE SPACE.
  22983. 020100     03  HDR-DA        PIC  Z9.
  22984. 020200     03  FILLER          PIC  X(04)
  22985. 020300         VALUE ", 19".
  22986. 020400     03  HDR-YR        PIC  9(02).
  22987. 020500     03  FILLER          PIC  X(02)
  22988. 020600         VALUE SPACES.
  22989. 020700     03  HDR-HR        PIC  9(02).
  22990. 020800     03  FILLER          PIC  X(01)
  22991. 020900         VALUE ":".
  22992. 021000     03  HDR-MIN       PIC  9(02).
  22993. 021100     03  FILLER          PIC  X(22)
  22994. 021200         VALUE SPACES.
  22995. 021300     03  FILLER        PIC X(23) VALUE "U.S.D.I. BUREAU OF LAND".
  22996. 021400     03  FILLER        PIC X(11) VALUE " MANAGEMENT".
  22997. 021500     03  FILLER          PIC  X(22)
  22998. 021600         VALUE SPACES.
  22999. 021700     03  FILLER        PIC X(15) VALUE "PCN: P01B      ".
  23000. 021800     03  FILLER        PIC X(6) VALUE " PAGE ".
  23001. 021900     03  HDR-PG        PIC ZZ,ZZ9.
  23002. 022000 01  HDR-2.
  23003. 022100     03  FILLER          PIC X(8)
  23004. 022200         VALUE "STATE:  ".
  23005. 022300     03  HDR-ST         PIC  X(02).
  23006. 022400     03  FILLER          PIC  X(04)
  23007. 022500         VALUE SPACES.
  23008. 022600     03  HDR-ST-NAM    PIC  X(10).
  23009. 022700     03  FILLER          PIC  X(30)
  23010. 022800         VALUE SPACES.
  23011. 022900     03  FILLER          PIC  X(25)
  23012. 023000         VALUE "ECOLOGICAL SITE INVENTORY".
  23013. 023100     03  FILLER          PIC  X(38)
  23014. 023200         VALUE SPACES.
  23015. 023300     03  FILLER          PIC  X(06)
  23016. 023400         VALUE SPACE.
  23017. 023500     03  FILLER        PIC X(9)
  23018. 023600         VALUE SPACE.
  23019. 023700 01  HDR-3.
  23020. 023800     03  FILLER          PIC  X(08)
  23021. 023900         VALUE "   DI:  ".
  23022. 024000     03  HDR-DIST        PIC  X(02).
  23023. 024100     03  FILLER          PIC  X(04)
  23024. 024200         VALUE SPACES.
  23025. 024300     03  HDR-DIST-NAM    PIC  X(12).
  23026. 024400     03  FILLER          PIC  X(106)
  23027. 024500         VALUE SPACES.
  23028. 024600 01  HDR-4.
  23029. 024700     03  FILLER          PIC  X(08)
  23030. 024800         VALUE "   RA:  ".
  23031. 024900     03  HDR-RA          PIC  X(02).
  23032. 025000     03  FILLER          PIC  X(04)
  23033. 025100         VALUE SPACES.
  23034. 025200     03  HDR-RA-NAM      PIC  X(18).
  23035. 025300     03  FILLER          PIC  X(09)
  23036. 025400         VALUE SPACES.
  23037. 025500     03  FILLER          PIC X(25)
  23038. 025600        VALUE "ECOLOGICAL CONDITION CLAS".
  23039. 025700     03  FILLER          PIC X(25)
  23040. 025800         VALUE "S/ESTIMATED STOCKING RATE".
  23041. 025900     03  HDR-4-REMARK    PIC X(37)
  23042. 026000         VALUE SPACE.
  23043. 026100     03  FILLER          PIC  X(10)
  23044. 026200         VALUE SPACES.
  23045. 026300 01  HDR-5.
  23046. 026400     03  FILLER          PIC  X(08)
  23047. 026500         VALUE "  PLU:  ".
  23048. 026600     03  HDR-PLU         PIC  X(02).
  23049. 026700     03  FILLER          PIC  X(04)
  23050. 026800         VALUE SPACES.
  23051. 026900     03  HDR-PLU-NAM     PIC  X(18).
  23052. 027000     03  FILLER          PIC  X(100)
  23053. 027100         VALUE SPACES.
  23054. 027200 01  HDR-6                  PIC X(132).
  23055. 027300 01  HDR-6A.
  23056. 027400     03  FILLER          PIC  X(08)
  23057. 027500         VALUE "  INV:  ".
  23058. 027600     03  HDR-INV-A         PIC  X(04).
  23059. 027700     03  FILLER          PIC  X(02)
  23060. 027800         VALUE SPACES.
  23061. 027900     03  HDR-INV-NAM-A     PIC  X(18).
  23062. 028000     03  FILLER          PIC  X(20)
  23063. 028100         VALUE SPACES.
  23064. 028200     03  FILLER          PIC  X(10)
  23065. 028300         VALUE "ALLOTMENT ".
  23066. 028400     03  HDR-ALOT        PIC XXXX.
  23067. 028500     03  FILLER          PIC X(11)
  23068. 028600         VALUE "   PASTURE ".
  23069. 028700     03  HDR-PAST        PIC XX.
  23070. 028800     03  FILLER          PIC X(54)
  23071. 028900         VALUE SPACES.
  23072. 029000 01  HDR-6B.
  23073. 029100     03  FILLER          PIC  X(08)
  23074. 029200         VALUE "  INV:  ".
  23075. 029300     03  HDR-INV-B         PIC  X(04).
  23076. 029400     03  FILLER          PIC  X(02)
  23077. 029500         VALUE SPACES.
  23078. 029600     03  HDR-INV-NAM-B    PIC  X(18).
  23079. 029700     03  FILLER          PIC  X(100)
  23080. 029800         VALUE SPACES.
  23081. 029900 01  HDR-7.
  23082. 030000     03  FILLER          PIC  X(33)
  23083. 030100         VALUE "     RANGE SITE  STRATUM  ESTIMAT".
  23084. 030200     03  FILLER          PIC  X(33)
  23085. 030300         VALUE "ED     ACRES     OWNER    JURIS  ".
  23086. 030400     03  FILLER          PIC  X(33)
  23087. 030500         VALUE " ADMIN   LAND            ESTIMATE".
  23088. 030600     03  FILLER          PIC  X(33)
  23089. 030700         VALUE "D AUMS                           ".
  23090. 030800 01  HDR-8.
  23091. 030900     03  FILLER          PIC  X(33)
  23092. 031000         VALUE "                          CONDITI".
  23093. 031100     03  FILLER          PIC  X(33)
  23094. 031200         VALUE "ON              PCT CD           ".
  23095. 031300     03  FILLER          PIC  X(33)
  23096. 031400         VALUE "         TYPE       PRESENT      ".
  23097. 031500     03  FILLER          PIC  X(33)
  23098. 031600         VALUE "   POTENTIAL                     ".
  23099. 031700 01  HDR-9.
  23100. 031800     03  RMK-H9          PIC  X(12)
  23101. 031900         VALUE "ALLOT/PAST  ".
  23102. 032000     03  FILLER          PIC  X(21)
  23103. 032100         VALUE "RANGE SITE      ACRES".
  23104. 032200     03  FILLER          PIC  X(33)
  23105. 032300         VALUE "           ESTIMATED AUMS        ".
  23106. 032400     03  FILLER          PIC  X(33)
  23107. 032500         VALUE SPACE.
  23108. 032600     03  FILLER          PIC  X(33)
  23109. 032700         VALUE SPACE.
  23110. 032800 01  HDR-10.
  23111. 032900     03  FILLER          PIC  X(33)
  23112. 033000         VALUE SPACE.
  23113. 033100     03  FILLER          PIC  X(33)
  23114. 033200         VALUE "       PRESENT     POTENTIAL     ".
  23115. 033300     03  FILLER          PIC  X(33)
  23116. 033400         VALUE SPACE.
  23117. 033500     03  FILLER          PIC  X(33)
  23118. 033600         VALUE SPACE.
  23119. 033700 01  HDR-11.
  23120. 033800     03  FILLER          PIC  X(33)
  23121. 033900         VALUE "           OWNER     ACRES  ESTIM".
  23122. 034000     03  FILLER          PIC  X(33)
  23123. 034100         VALUE "ATED        ESTIMATED AUMS       ".
  23124. 034200     03  FILLER          PIC  X(33)
  23125. 034300         VALUE SPACE.
  23126. 034400     03  FILLER          PIC  X(33)
  23127. 034500         VALUE SPACE.
  23128. 034600 01  HDR-12.
  23129. 034700     03  FILLER          PIC  X(33)
  23130. 034800         VALUE "                            CONDI".
  23131. 034900     03  FILLER          PIC  X(33)
  23132. 035000         VALUE "TION    PRESENT     POTENTIAL    ".
  23133. 035100     03  FILLER          PIC  X(33)
  23134. 035200         VALUE SPACE.
  23135. 035300     03  FILLER          PIC  X(33)
  23136. 035400         VALUE SPACE.
  23137. 035500 01  HDR-13.
  23138. 035600     03  FILLER          PIC  X(33)
  23139. 035700         VALUE "                    ACRES  PERCEN".
  23140. 035800     03  FILLER          PIC  X(33)
  23141. 035900         VALUE "T  ESTIMATED        ESTIMATED AUM".
  23142. 036000     03  FILLER          PIC  X(33)
  23143. 036100         VALUE "S                                ".
  23144. 036200     03